git-cvsserver.perl 159 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109
  1. #!/usr/bin/perl
  2. ####
  3. #### This application is a CVS emulation layer for git.
  4. #### It is intended for clients to connect over SSH.
  5. #### See the documentation for more details.
  6. ####
  7. #### Copyright The Open University UK - 2006.
  8. ####
  9. #### Authors: Martyn Smith <martyn@catalyst.net.nz>
  10. #### Martin Langhoff <martin@laptop.org>
  11. ####
  12. ####
  13. #### Released under the GNU Public License, version 2.
  14. ####
  15. ####
  16. use 5.008;
  17. use strict;
  18. use warnings;
  19. use bytes;
  20. use Fcntl;
  21. use File::Temp qw/tempdir tempfile/;
  22. use File::Path qw/rmtree/;
  23. use File::Basename;
  24. use Getopt::Long qw(:config require_order no_ignore_case);
  25. my $VERSION = '@@GIT_VERSION@@';
  26. my $log = GITCVS::log->new();
  27. my $cfg;
  28. my $DATE_LIST = {
  29. Jan => "01",
  30. Feb => "02",
  31. Mar => "03",
  32. Apr => "04",
  33. May => "05",
  34. Jun => "06",
  35. Jul => "07",
  36. Aug => "08",
  37. Sep => "09",
  38. Oct => "10",
  39. Nov => "11",
  40. Dec => "12",
  41. };
  42. # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
  43. $| = 1;
  44. #### Definition and mappings of functions ####
  45. # NOTE: Despite the existence of req_CATCHALL and req_EMPTY unimplemented
  46. # requests, this list is incomplete. It is missing many rarer/optional
  47. # requests. Perhaps some clients require a claim of support for
  48. # these specific requests for main functionality to work?
  49. my $methods = {
  50. 'Root' => \&req_Root,
  51. 'Valid-responses' => \&req_Validresponses,
  52. 'valid-requests' => \&req_validrequests,
  53. 'Directory' => \&req_Directory,
  54. 'Sticky' => \&req_Sticky,
  55. 'Entry' => \&req_Entry,
  56. 'Modified' => \&req_Modified,
  57. 'Unchanged' => \&req_Unchanged,
  58. 'Questionable' => \&req_Questionable,
  59. 'Argument' => \&req_Argument,
  60. 'Argumentx' => \&req_Argument,
  61. 'expand-modules' => \&req_expandmodules,
  62. 'add' => \&req_add,
  63. 'remove' => \&req_remove,
  64. 'co' => \&req_co,
  65. 'update' => \&req_update,
  66. 'ci' => \&req_ci,
  67. 'diff' => \&req_diff,
  68. 'log' => \&req_log,
  69. 'rlog' => \&req_log,
  70. 'tag' => \&req_CATCHALL,
  71. 'status' => \&req_status,
  72. 'admin' => \&req_CATCHALL,
  73. 'history' => \&req_CATCHALL,
  74. 'watchers' => \&req_EMPTY,
  75. 'editors' => \&req_EMPTY,
  76. 'noop' => \&req_EMPTY,
  77. 'annotate' => \&req_annotate,
  78. 'Global_option' => \&req_Globaloption,
  79. };
  80. ##############################################
  81. # $state holds all the bits of information the clients sends us that could
  82. # potentially be useful when it comes to actually _doing_ something.
  83. my $state = { prependdir => '' };
  84. # Work is for managing temporary working directory
  85. my $work =
  86. {
  87. state => undef, # undef, 1 (empty), 2 (with stuff)
  88. workDir => undef,
  89. index => undef,
  90. emptyDir => undef,
  91. tmpDir => undef
  92. };
  93. $log->info("--------------- STARTING -----------------");
  94. my $usage =
  95. "usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
  96. " --base-path <path> : Prepend to requested CVSROOT\n".
  97. " Can be read from GIT_CVSSERVER_BASE_PATH\n".
  98. " --strict-paths : Don't allow recursing into subdirectories\n".
  99. " --export-all : Don't check for gitcvs.enabled in config\n".
  100. " --version, -V : Print version information and exit\n".
  101. " -h, -H : Print usage information and exit\n".
  102. "\n".
  103. "<directory> ... is a list of allowed directories. If no directories\n".
  104. "are given, all are allowed. This is an additional restriction, gitcvs\n".
  105. "access still needs to be enabled by the gitcvs.enabled config option.\n".
  106. "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
  107. my @opts = ( 'h|H', 'version|V',
  108. 'base-path=s', 'strict-paths', 'export-all' );
  109. GetOptions( $state, @opts )
  110. or die $usage;
  111. if ($state->{version}) {
  112. print "git-cvsserver version $VERSION\n";
  113. exit;
  114. }
  115. if ($state->{help}) {
  116. print $usage;
  117. exit;
  118. }
  119. my $TEMP_DIR = tempdir( CLEANUP => 1 );
  120. $log->debug("Temporary directory is '$TEMP_DIR'");
  121. $state->{method} = 'ext';
  122. if (@ARGV) {
  123. if ($ARGV[0] eq 'pserver') {
  124. $state->{method} = 'pserver';
  125. shift @ARGV;
  126. } elsif ($ARGV[0] eq 'server') {
  127. shift @ARGV;
  128. }
  129. }
  130. # everything else is a directory
  131. $state->{allowed_roots} = [ @ARGV ];
  132. # don't export the whole system unless the users requests it
  133. if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
  134. die "--export-all can only be used together with an explicit whitelist\n";
  135. }
  136. # Environment handling for running under git-shell
  137. if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
  138. if ($state->{'base-path'}) {
  139. die "Cannot specify base path both ways.\n";
  140. }
  141. my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH};
  142. $state->{'base-path'} = $base_path;
  143. $log->debug("Picked up base path '$base_path' from environment.\n");
  144. }
  145. if (exists $ENV{GIT_CVSSERVER_ROOT}) {
  146. if (@{$state->{allowed_roots}}) {
  147. die "Cannot specify roots both ways: @ARGV\n";
  148. }
  149. my $allowed_root = $ENV{GIT_CVSSERVER_ROOT};
  150. $state->{allowed_roots} = [ $allowed_root ];
  151. $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
  152. }
  153. # if we are called with a pserver argument,
  154. # deal with the authentication cat before entering the
  155. # main loop
  156. if ($state->{method} eq 'pserver') {
  157. my $line = <STDIN>; chomp $line;
  158. unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
  159. die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
  160. }
  161. my $request = $1;
  162. $line = <STDIN>; chomp $line;
  163. unless (req_Root('root', $line)) { # reuse Root
  164. print "E Invalid root $line \n";
  165. exit 1;
  166. }
  167. $line = <STDIN>; chomp $line;
  168. my $user = $line;
  169. $line = <STDIN>; chomp $line;
  170. my $password = $line;
  171. if ($user eq 'anonymous') {
  172. # "A" will be 1 byte, use length instead in case the
  173. # encryption method ever changes (yeah, right!)
  174. if (length($password) > 1 ) {
  175. print "E Don't supply a password for the `anonymous' user\n";
  176. print "I HATE YOU\n";
  177. exit 1;
  178. }
  179. # Fall through to LOVE
  180. } else {
  181. # Trying to authenticate a user
  182. if (not exists $cfg->{gitcvs}->{authdb}) {
  183. print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
  184. print "I HATE YOU\n";
  185. exit 1;
  186. }
  187. my $authdb = $cfg->{gitcvs}->{authdb};
  188. unless (-e $authdb) {
  189. print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
  190. print "I HATE YOU\n";
  191. exit 1;
  192. }
  193. my $auth_ok;
  194. open my $passwd, "<", $authdb or die $!;
  195. while (<$passwd>) {
  196. if (m{^\Q$user\E:(.*)}) {
  197. if (crypt($user, descramble($password)) eq $1) {
  198. $auth_ok = 1;
  199. }
  200. };
  201. }
  202. close $passwd;
  203. unless ($auth_ok) {
  204. print "I HATE YOU\n";
  205. exit 1;
  206. }
  207. # Fall through to LOVE
  208. }
  209. # For checking whether the user is anonymous on commit
  210. $state->{user} = $user;
  211. $line = <STDIN>; chomp $line;
  212. unless ($line eq "END $request REQUEST") {
  213. die "E Do not understand $line -- expecting END $request REQUEST\n";
  214. }
  215. print "I LOVE YOU\n";
  216. exit if $request eq 'VERIFICATION'; # cvs login
  217. # and now back to our regular programme...
  218. }
  219. # Keep going until the client closes the connection
  220. while (<STDIN>)
  221. {
  222. chomp;
  223. # Check to see if we've seen this method, and call appropriate function.
  224. if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
  225. {
  226. # use the $methods hash to call the appropriate sub for this command
  227. #$log->info("Method : $1");
  228. &{$methods->{$1}}($1,$2);
  229. } else {
  230. # log fatal because we don't understand this function. If this happens
  231. # we're fairly screwed because we don't know if the client is expecting
  232. # a response. If it is, the client will hang, we'll hang, and the whole
  233. # thing will be custard.
  234. $log->fatal("Don't understand command $_\n");
  235. die("Unknown command $_");
  236. }
  237. }
  238. $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
  239. $log->info("--------------- FINISH -----------------");
  240. chdir '/';
  241. exit 0;
  242. # Magic catchall method.
  243. # This is the method that will handle all commands we haven't yet
  244. # implemented. It simply sends a warning to the log file indicating a
  245. # command that hasn't been implemented has been invoked.
  246. sub req_CATCHALL
  247. {
  248. my ( $cmd, $data ) = @_;
  249. $log->warn("Unhandled command : req_$cmd : $data");
  250. }
  251. # This method invariably succeeds with an empty response.
  252. sub req_EMPTY
  253. {
  254. print "ok\n";
  255. }
  256. # Root pathname \n
  257. # Response expected: no. Tell the server which CVSROOT to use. Note that
  258. # pathname is a local directory and not a fully qualified CVSROOT variable.
  259. # pathname must already exist; if creating a new root, use the init
  260. # request, not Root. pathname does not include the hostname of the server,
  261. # how to access the server, etc.; by the time the CVS protocol is in use,
  262. # connection, authentication, etc., are already taken care of. The Root
  263. # request must be sent only once, and it must be sent before any requests
  264. # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
  265. sub req_Root
  266. {
  267. my ( $cmd, $data ) = @_;
  268. $log->debug("req_Root : $data");
  269. unless ($data =~ m#^/#) {
  270. print "error 1 Root must be an absolute pathname\n";
  271. return 0;
  272. }
  273. my $cvsroot = $state->{'base-path'} || '';
  274. $cvsroot =~ s#/+$##;
  275. $cvsroot .= $data;
  276. if ($state->{CVSROOT}
  277. && ($state->{CVSROOT} ne $cvsroot)) {
  278. print "error 1 Conflicting roots specified\n";
  279. return 0;
  280. }
  281. $state->{CVSROOT} = $cvsroot;
  282. $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
  283. if (@{$state->{allowed_roots}}) {
  284. my $allowed = 0;
  285. foreach my $dir (@{$state->{allowed_roots}}) {
  286. next unless $dir =~ m#^/#;
  287. $dir =~ s#/+$##;
  288. if ($state->{'strict-paths'}) {
  289. if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
  290. $allowed = 1;
  291. last;
  292. }
  293. } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
  294. $allowed = 1;
  295. last;
  296. }
  297. }
  298. unless ($allowed) {
  299. print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
  300. print "E \n";
  301. print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
  302. return 0;
  303. }
  304. }
  305. unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
  306. print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
  307. print "E \n";
  308. print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
  309. return 0;
  310. }
  311. my @gitvars = safe_pipe_capture(qw(git config -l));
  312. if ($?) {
  313. print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
  314. print "E \n";
  315. print "error 1 - problem executing git-config\n";
  316. return 0;
  317. }
  318. foreach my $line ( @gitvars )
  319. {
  320. next unless ( $line =~ /^(gitcvs|extensions)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
  321. unless ($2) {
  322. $cfg->{$1}{$3} = $4;
  323. } else {
  324. $cfg->{$1}{$2}{$3} = $4;
  325. }
  326. }
  327. my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
  328. || $cfg->{gitcvs}{enabled});
  329. unless ($state->{'export-all'} ||
  330. ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
  331. print "E GITCVS emulation needs to be enabled on this repo\n";
  332. print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
  333. print "E \n";
  334. print "error 1 GITCVS emulation disabled\n";
  335. return 0;
  336. }
  337. my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
  338. if ( $logfile )
  339. {
  340. $log->setfile($logfile);
  341. } else {
  342. $log->nofile();
  343. }
  344. $state->{rawsz} = ($cfg->{'extensions'}{'objectformat'} || 'sha1') eq 'sha256' ? 32 : 20;
  345. $state->{hexsz} = $state->{rawsz} * 2;
  346. return 1;
  347. }
  348. # Global_option option \n
  349. # Response expected: no. Transmit one of the global options `-q', `-Q',
  350. # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
  351. # variations (such as combining of options) are allowed. For graceful
  352. # handling of valid-requests, it is probably better to make new global
  353. # options separate requests, rather than trying to add them to this
  354. # request.
  355. sub req_Globaloption
  356. {
  357. my ( $cmd, $data ) = @_;
  358. $log->debug("req_Globaloption : $data");
  359. $state->{globaloptions}{$data} = 1;
  360. }
  361. # Valid-responses request-list \n
  362. # Response expected: no. Tell the server what responses the client will
  363. # accept. request-list is a space separated list of tokens.
  364. sub req_Validresponses
  365. {
  366. my ( $cmd, $data ) = @_;
  367. $log->debug("req_Validresponses : $data");
  368. # TODO : re-enable this, currently it's not particularly useful
  369. #$state->{validresponses} = [ split /\s+/, $data ];
  370. }
  371. # valid-requests \n
  372. # Response expected: yes. Ask the server to send back a Valid-requests
  373. # response.
  374. sub req_validrequests
  375. {
  376. my ( $cmd, $data ) = @_;
  377. $log->debug("req_validrequests");
  378. $log->debug("SEND : Valid-requests " . join(" ",sort keys %$methods));
  379. $log->debug("SEND : ok");
  380. print "Valid-requests " . join(" ",sort keys %$methods) . "\n";
  381. print "ok\n";
  382. }
  383. # Directory local-directory \n
  384. # Additional data: repository \n. Response expected: no. Tell the server
  385. # what directory to use. The repository should be a directory name from a
  386. # previous server response. Note that this both gives a default for Entry
  387. # and Modified and also for ci and the other commands; normal usage is to
  388. # send Directory for each directory in which there will be an Entry or
  389. # Modified, and then a final Directory for the original directory, then the
  390. # command. The local-directory is relative to the top level at which the
  391. # command is occurring (i.e. the last Directory which is sent before the
  392. # command); to indicate that top level, `.' should be sent for
  393. # local-directory.
  394. sub req_Directory
  395. {
  396. my ( $cmd, $data ) = @_;
  397. my $repository = <STDIN>;
  398. chomp $repository;
  399. $state->{localdir} = $data;
  400. $state->{repository} = $repository;
  401. $state->{path} = $repository;
  402. $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
  403. $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
  404. $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
  405. $state->{directory} = $state->{localdir};
  406. $state->{directory} = "" if ( $state->{directory} eq "." );
  407. $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
  408. if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
  409. {
  410. $log->info("Setting prepend to '$state->{path}'");
  411. $state->{prependdir} = $state->{path};
  412. my %entries;
  413. foreach my $entry ( keys %{$state->{entries}} )
  414. {
  415. $entries{$state->{prependdir} . $entry} = $state->{entries}{$entry};
  416. }
  417. $state->{entries}=\%entries;
  418. my %dirMap;
  419. foreach my $dir ( keys %{$state->{dirMap}} )
  420. {
  421. $dirMap{$state->{prependdir} . $dir} = $state->{dirMap}{$dir};
  422. }
  423. $state->{dirMap}=\%dirMap;
  424. }
  425. if ( defined ( $state->{prependdir} ) )
  426. {
  427. $log->debug("Prepending '$state->{prependdir}' to state|directory");
  428. $state->{directory} = $state->{prependdir} . $state->{directory}
  429. }
  430. if ( ! defined($state->{dirMap}{$state->{directory}}) )
  431. {
  432. $state->{dirMap}{$state->{directory}} =
  433. {
  434. 'names' => {}
  435. #'tagspec' => undef
  436. };
  437. }
  438. $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
  439. }
  440. # Sticky tagspec \n
  441. # Response expected: no. Tell the server that the directory most
  442. # recently specified with Directory has a sticky tag or date
  443. # tagspec. The first character of tagspec is T for a tag, D for
  444. # a date, or some other character supplied by a Set-sticky
  445. # response from a previous request to the server. The remainder
  446. # of tagspec contains the actual tag or date, again as supplied
  447. # by Set-sticky.
  448. # The server should remember Static-directory and Sticky requests
  449. # for a particular directory; the client need not resend them each
  450. # time it sends a Directory request for a given directory. However,
  451. # the server is not obliged to remember them beyond the context
  452. # of a single command.
  453. sub req_Sticky
  454. {
  455. my ( $cmd, $tagspec ) = @_;
  456. my ( $stickyInfo );
  457. if($tagspec eq "")
  458. {
  459. # nothing
  460. }
  461. elsif($tagspec=~/^T([^ ]+)\s*$/)
  462. {
  463. $stickyInfo = { 'tag' => $1 };
  464. }
  465. elsif($tagspec=~/^D([0-9.]+)\s*$/)
  466. {
  467. $stickyInfo= { 'date' => $1 };
  468. }
  469. else
  470. {
  471. die "Unknown tag_or_date format\n";
  472. }
  473. $state->{dirMap}{$state->{directory}}{stickyInfo}=$stickyInfo;
  474. $log->debug("req_Sticky : tagspec=$tagspec repository=$state->{repository}"
  475. . " path=$state->{path} directory=$state->{directory}"
  476. . " module=$state->{module}");
  477. }
  478. # Entry entry-line \n
  479. # Response expected: no. Tell the server what version of a file is on the
  480. # local machine. The name in entry-line is a name relative to the directory
  481. # most recently specified with Directory. If the user is operating on only
  482. # some files in a directory, Entry requests for only those files need be
  483. # included. If an Entry request is sent without Modified, Is-modified, or
  484. # Unchanged, it means the file is lost (does not exist in the working
  485. # directory). If both Entry and one of Modified, Is-modified, or Unchanged
  486. # are sent for the same file, Entry must be sent first. For a given file,
  487. # one can send Modified, Is-modified, or Unchanged, but not more than one
  488. # of these three.
  489. sub req_Entry
  490. {
  491. my ( $cmd, $data ) = @_;
  492. #$log->debug("req_Entry : $data");
  493. my @data = split(/\//, $data, -1);
  494. $state->{entries}{$state->{directory}.$data[1]} = {
  495. revision => $data[2],
  496. conflict => $data[3],
  497. options => $data[4],
  498. tag_or_date => $data[5],
  499. };
  500. $state->{dirMap}{$state->{directory}}{names}{$data[1]} = 'F';
  501. $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
  502. }
  503. # Questionable filename \n
  504. # Response expected: no. Additional data: no. Tell the server to check
  505. # whether filename should be ignored, and if not, next time the server
  506. # sends responses, send (in a M response) `?' followed by the directory and
  507. # filename. filename must not contain `/'; it needs to be a file in the
  508. # directory named by the most recent Directory request.
  509. sub req_Questionable
  510. {
  511. my ( $cmd, $data ) = @_;
  512. $log->debug("req_Questionable : $data");
  513. $state->{entries}{$state->{directory}.$data}{questionable} = 1;
  514. }
  515. # add \n
  516. # Response expected: yes. Add a file or directory. This uses any previous
  517. # Argument, Directory, Entry, or Modified requests, if they have been sent.
  518. # The last Directory sent specifies the working directory at the time of
  519. # the operation. To add a directory, send the directory to be added using
  520. # Directory and Argument requests.
  521. sub req_add
  522. {
  523. my ( $cmd, $data ) = @_;
  524. argsplit("add");
  525. my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
  526. $updater->update();
  527. my $addcount = 0;
  528. foreach my $filename ( @{$state->{args}} )
  529. {
  530. $filename = filecleanup($filename);
  531. # no -r, -A, or -D with add
  532. my $stickyInfo = resolveStickyInfo($filename);
  533. my $meta = $updater->getmeta($filename,$stickyInfo);
  534. my $wrev = revparse($filename);
  535. if ($wrev && $meta && ($wrev=~/^-/))
  536. {
  537. # previously removed file, add back
  538. $log->info("added file $filename was previously removed, send $meta->{revision}");
  539. print "MT +updated\n";
  540. print "MT text U \n";
  541. print "MT fname $filename\n";
  542. print "MT newline\n";
  543. print "MT -updated\n";
  544. unless ( $state->{globaloptions}{-n} )
  545. {
  546. my ( $filepart, $dirpart ) = filenamesplit($filename,1);
  547. print "Created $dirpart\n";
  548. print $state->{CVSROOT} . "/$state->{module}/$filename\n";
  549. # this is an "entries" line
  550. my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
  551. my $entryLine = "/$filepart/$meta->{revision}//$kopts/";
  552. $entryLine .= getStickyTagOrDate($stickyInfo);
  553. $log->debug($entryLine);
  554. print "$entryLine\n";
  555. # permissions
  556. $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
  557. print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
  558. # transmit file
  559. transmitfile($meta->{filehash});
  560. }
  561. next;
  562. }
  563. unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
  564. {
  565. print "E cvs add: nothing known about `$filename'\n";
  566. next;
  567. }
  568. # TODO : check we're not squashing an already existing file
  569. if ( defined ( $state->{entries}{$filename}{revision} ) )
  570. {
  571. print "E cvs add: `$filename' has already been entered\n";
  572. next;
  573. }
  574. my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
  575. print "E cvs add: scheduling file `$filename' for addition\n";
  576. print "Checked-in $dirpart\n";
  577. print "$filename\n";
  578. my $kopts = kopts_from_path($filename,"file",
  579. $state->{entries}{$filename}{modified_filename});
  580. print "/$filepart/0//$kopts/" .
  581. getStickyTagOrDate($stickyInfo) . "\n";
  582. my $requestedKopts = $state->{opt}{k};
  583. if(defined($requestedKopts))
  584. {
  585. $requestedKopts = "-k$requestedKopts";
  586. }
  587. else
  588. {
  589. $requestedKopts = "";
  590. }
  591. if( $kopts ne $requestedKopts )
  592. {
  593. $log->warn("Ignoring requested -k='$requestedKopts'"
  594. . " for '$filename'; detected -k='$kopts' instead");
  595. #TODO: Also have option to send warning to user?
  596. }
  597. $addcount++;
  598. }
  599. if ( $addcount == 1 )
  600. {
  601. print "E cvs add: use `cvs commit' to add this file permanently\n";
  602. }
  603. elsif ( $addcount > 1 )
  604. {
  605. print "E cvs add: use `cvs commit' to add these files permanently\n";
  606. }
  607. print "ok\n";
  608. }
  609. # remove \n
  610. # Response expected: yes. Remove a file. This uses any previous Argument,
  611. # Directory, Entry, or Modified requests, if they have been sent. The last
  612. # Directory sent specifies the working directory at the time of the
  613. # operation. Note that this request does not actually do anything to the
  614. # repository; the only effect of a successful remove request is to supply
  615. # the client with a new entries line containing `-' to indicate a removed
  616. # file. In fact, the client probably could perform this operation without
  617. # contacting the server, although using remove may cause the server to
  618. # perform a few more checks. The client sends a subsequent ci request to
  619. # actually record the removal in the repository.
  620. sub req_remove
  621. {
  622. my ( $cmd, $data ) = @_;
  623. argsplit("remove");
  624. # Grab a handle to the SQLite db and do any necessary updates
  625. my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
  626. $updater->update();
  627. #$log->debug("add state : " . Dumper($state));
  628. my $rmcount = 0;
  629. foreach my $filename ( @{$state->{args}} )
  630. {
  631. $filename = filecleanup($filename);
  632. if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
  633. {
  634. print "E cvs remove: file `$filename' still in working directory\n";
  635. next;
  636. }
  637. # only from entries
  638. my $stickyInfo = resolveStickyInfo($filename);
  639. my $meta = $updater->getmeta($filename,$stickyInfo);
  640. my $wrev = revparse($filename);
  641. unless ( defined ( $wrev ) )
  642. {
  643. print "E cvs remove: nothing known about `$filename'\n";
  644. next;
  645. }
  646. if ( defined($wrev) and ($wrev=~/^-/) )
  647. {
  648. print "E cvs remove: file `$filename' already scheduled for removal\n";
  649. next;
  650. }
  651. unless ( $wrev eq $meta->{revision} )
  652. {
  653. # TODO : not sure if the format of this message is quite correct.
  654. print "E cvs remove: Up to date check failed for `$filename'\n";
  655. next;
  656. }
  657. my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
  658. print "E cvs remove: scheduling `$filename' for removal\n";
  659. print "Checked-in $dirpart\n";
  660. print "$filename\n";
  661. my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
  662. print "/$filepart/-$wrev//$kopts/" . getStickyTagOrDate($stickyInfo) . "\n";
  663. $rmcount++;
  664. }
  665. if ( $rmcount == 1 )
  666. {
  667. print "E cvs remove: use `cvs commit' to remove this file permanently\n";
  668. }
  669. elsif ( $rmcount > 1 )
  670. {
  671. print "E cvs remove: use `cvs commit' to remove these files permanently\n";
  672. }
  673. print "ok\n";
  674. }
  675. # Modified filename \n
  676. # Response expected: no. Additional data: mode, \n, file transmission. Send
  677. # the server a copy of one locally modified file. filename is a file within
  678. # the most recent directory sent with Directory; it must not contain `/'.
  679. # If the user is operating on only some files in a directory, only those
  680. # files need to be included. This can also be sent without Entry, if there
  681. # is no entry for the file.
  682. sub req_Modified
  683. {
  684. my ( $cmd, $data ) = @_;
  685. my $mode = <STDIN>;
  686. defined $mode
  687. or (print "E end of file reading mode for $data\n"), return;
  688. chomp $mode;
  689. my $size = <STDIN>;
  690. defined $size
  691. or (print "E end of file reading size of $data\n"), return;
  692. chomp $size;
  693. # Grab config information
  694. my $blocksize = 8192;
  695. my $bytesleft = $size;
  696. my $tmp;
  697. # Get a filehandle/name to write it to
  698. my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
  699. # Loop over file data writing out to temporary file.
  700. while ( $bytesleft )
  701. {
  702. $blocksize = $bytesleft if ( $bytesleft < $blocksize );
  703. read STDIN, $tmp, $blocksize;
  704. print $fh $tmp;
  705. $bytesleft -= $blocksize;
  706. }
  707. close $fh
  708. or (print "E failed to write temporary, $filename: $!\n"), return;
  709. # Ensure we have something sensible for the file mode
  710. if ( $mode =~ /u=(\w+)/ )
  711. {
  712. $mode = $1;
  713. } else {
  714. $mode = "rw";
  715. }
  716. # Save the file data in $state
  717. $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
  718. $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
  719. $state->{entries}{$state->{directory}.$data}{modified_hash} = safe_pipe_capture('git','hash-object',$filename);
  720. $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
  721. #$log->debug("req_Modified : file=$data mode=$mode size=$size");
  722. }
  723. # Unchanged filename \n
  724. # Response expected: no. Tell the server that filename has not been
  725. # modified in the checked out directory. The filename is a file within the
  726. # most recent directory sent with Directory; it must not contain `/'.
  727. sub req_Unchanged
  728. {
  729. my ( $cmd, $data ) = @_;
  730. $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
  731. #$log->debug("req_Unchanged : $data");
  732. }
  733. # Argument text \n
  734. # Response expected: no. Save argument for use in a subsequent command.
  735. # Arguments accumulate until an argument-using command is given, at which
  736. # point they are forgotten.
  737. # Argumentx text \n
  738. # Response expected: no. Append \n followed by text to the current argument
  739. # being saved.
  740. sub req_Argument
  741. {
  742. my ( $cmd, $data ) = @_;
  743. # Argumentx means: append to last Argument (with a newline in front)
  744. $log->debug("$cmd : $data");
  745. if ( $cmd eq 'Argumentx') {
  746. ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
  747. } else {
  748. push @{$state->{arguments}}, $data;
  749. }
  750. }
  751. # expand-modules \n
  752. # Response expected: yes. Expand the modules which are specified in the
  753. # arguments. Returns the data in Module-expansion responses. Note that the
  754. # server can assume that this is checkout or export, not rtag or rdiff; the
  755. # latter do not access the working directory and thus have no need to
  756. # expand modules on the client side. Expand may not be the best word for
  757. # what this request does. It does not necessarily tell you all the files
  758. # contained in a module, for example. Basically it is a way of telling you
  759. # which working directories the server needs to know about in order to
  760. # handle a checkout of the specified modules. For example, suppose that the
  761. # server has a module defined by
  762. # aliasmodule -a 1dir
  763. # That is, one can check out aliasmodule and it will take 1dir in the
  764. # repository and check it out to 1dir in the working directory. Now suppose
  765. # the client already has this module checked out and is planning on using
  766. # the co request to update it. Without using expand-modules, the client
  767. # would have two bad choices: it could either send information about all
  768. # working directories under the current directory, which could be
  769. # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
  770. # stands for 1dir, and neglect to send information for 1dir, which would
  771. # lead to incorrect operation. With expand-modules, the client would first
  772. # ask for the module to be expanded:
  773. sub req_expandmodules
  774. {
  775. my ( $cmd, $data ) = @_;
  776. argsplit();
  777. $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
  778. unless ( ref $state->{arguments} eq "ARRAY" )
  779. {
  780. print "ok\n";
  781. return;
  782. }
  783. foreach my $module ( @{$state->{arguments}} )
  784. {
  785. $log->debug("SEND : Module-expansion $module");
  786. print "Module-expansion $module\n";
  787. }
  788. print "ok\n";
  789. statecleanup();
  790. }
  791. # co \n
  792. # Response expected: yes. Get files from the repository. This uses any
  793. # previous Argument, Directory, Entry, or Modified requests, if they have
  794. # been sent. Arguments to this command are module names; the client cannot
  795. # know what directories they correspond to except by (1) just sending the
  796. # co request, and then seeing what directory names the server sends back in
  797. # its responses, and (2) the expand-modules request.
  798. sub req_co
  799. {
  800. my ( $cmd, $data ) = @_;
  801. argsplit("co");
  802. # Provide list of modules, if -c was used.
  803. if (exists $state->{opt}{c}) {
  804. my $showref = safe_pipe_capture(qw(git show-ref --heads));
  805. for my $line (split '\n', $showref) {
  806. if ( $line =~ m% refs/heads/(.*)$% ) {
  807. print "M $1\t$1\n";
  808. }
  809. }
  810. print "ok\n";
  811. return 1;
  812. }
  813. my $stickyInfo = { 'tag' => $state->{opt}{r},
  814. 'date' => $state->{opt}{D} };
  815. my $module = $state->{args}[0];
  816. $state->{module} = $module;
  817. my $checkout_path = $module;
  818. # use the user specified directory if we're given it
  819. $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
  820. $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
  821. $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
  822. $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
  823. # Grab a handle to the SQLite db and do any necessary updates
  824. my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
  825. $updater->update();
  826. my $headHash;
  827. if( defined($stickyInfo) && defined($stickyInfo->{tag}) )
  828. {
  829. $headHash = $updater->lookupCommitRef($stickyInfo->{tag});
  830. if( !defined($headHash) )
  831. {
  832. print "error 1 no such tag `$stickyInfo->{tag}'\n";
  833. cleanupWorkTree();
  834. exit;
  835. }
  836. }
  837. $checkout_path =~ s|/$||; # get rid of trailing slashes
  838. my %seendirs = ();
  839. my $lastdir ='';
  840. prepDirForOutput(
  841. ".",
  842. $state->{CVSROOT} . "/$module",
  843. $checkout_path,
  844. \%seendirs,
  845. 'checkout',
  846. $state->{dirArgs} );
  847. foreach my $git ( @{$updater->getAnyHead($headHash)} )
  848. {
  849. # Don't want to check out deleted files
  850. next if ( $git->{filehash} eq "deleted" );
  851. my $fullName = $git->{name};
  852. ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
  853. unless (exists($seendirs{$git->{dir}})) {
  854. prepDirForOutput($git->{dir}, $state->{CVSROOT} . "/$module/",
  855. $checkout_path, \%seendirs, 'checkout',
  856. $state->{dirArgs} );
  857. $lastdir = $git->{dir};
  858. $seendirs{$git->{dir}} = 1;
  859. }
  860. # modification time of this file
  861. print "Mod-time $git->{modified}\n";
  862. # print some information to the client
  863. if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
  864. {
  865. print "M U $checkout_path/$git->{dir}$git->{name}\n";
  866. } else {
  867. print "M U $checkout_path/$git->{name}\n";
  868. }
  869. # instruct client we're sending a file to put in this path
  870. print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
  871. print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
  872. # this is an "entries" line
  873. my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
  874. print "/$git->{name}/$git->{revision}//$kopts/" .
  875. getStickyTagOrDate($stickyInfo) . "\n";
  876. # permissions
  877. print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
  878. # transmit file
  879. transmitfile($git->{filehash});
  880. }
  881. print "ok\n";
  882. statecleanup();
  883. }
  884. # used by req_co and req_update to set up directories for files
  885. # recursively handles parents
  886. sub prepDirForOutput
  887. {
  888. my ($dir, $repodir, $remotedir, $seendirs, $request, $dirArgs) = @_;
  889. my $parent = dirname($dir);
  890. $dir =~ s|/+$||;
  891. $repodir =~ s|/+$||;
  892. $remotedir =~ s|/+$||;
  893. $parent =~ s|/+$||;
  894. if ($parent eq '.' || $parent eq './')
  895. {
  896. $parent = '';
  897. }
  898. # recurse to announce unseen parents first
  899. if( length($parent) &&
  900. !exists($seendirs->{$parent}) &&
  901. ( $request eq "checkout" ||
  902. exists($dirArgs->{$parent}) ) )
  903. {
  904. prepDirForOutput($parent, $repodir, $remotedir,
  905. $seendirs, $request, $dirArgs);
  906. }
  907. # Announce that we are going to modify at the parent level
  908. if ($dir eq '.' || $dir eq './')
  909. {
  910. $dir = '';
  911. }
  912. if(exists($seendirs->{$dir}))
  913. {
  914. return;
  915. }
  916. $log->debug("announcedir $dir, $repodir, $remotedir" );
  917. my($thisRemoteDir,$thisRepoDir);
  918. if ($dir ne "")
  919. {
  920. $thisRepoDir="$repodir/$dir";
  921. if($remotedir eq ".")
  922. {
  923. $thisRemoteDir=$dir;
  924. }
  925. else
  926. {
  927. $thisRemoteDir="$remotedir/$dir";
  928. }
  929. }
  930. else
  931. {
  932. $thisRepoDir=$repodir;
  933. $thisRemoteDir=$remotedir;
  934. }
  935. unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
  936. {
  937. print "E cvs $request: Updating $thisRemoteDir\n";
  938. }
  939. my ($opt_r)=$state->{opt}{r};
  940. my $stickyInfo;
  941. if(exists($state->{opt}{A}))
  942. {
  943. # $stickyInfo=undef;
  944. }
  945. elsif( defined($opt_r) && $opt_r ne "" )
  946. # || ( defined($state->{opt}{D}) && $state->{opt}{D} ne "" ) # TODO
  947. {
  948. $stickyInfo={ 'tag' => (defined($opt_r)?$opt_r:undef) };
  949. # TODO: Convert -D value into the form 2011.04.10.04.46.57,
  950. # similar to an entry line's sticky date, without the D prefix.
  951. # It sometimes (always?) arrives as something more like
  952. # '10 Apr 2011 04:46:57 -0000'...
  953. # $stickyInfo={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
  954. }
  955. else
  956. {
  957. $stickyInfo=getDirStickyInfo($state->{prependdir} . $dir);
  958. }
  959. my $stickyResponse;
  960. if(defined($stickyInfo))
  961. {
  962. $stickyResponse = "Set-sticky $thisRemoteDir/\n" .
  963. "$thisRepoDir/\n" .
  964. getStickyTagOrDate($stickyInfo) . "\n";
  965. }
  966. else
  967. {
  968. $stickyResponse = "Clear-sticky $thisRemoteDir/\n" .
  969. "$thisRepoDir/\n";
  970. }
  971. unless ( $state->{globaloptions}{-n} )
  972. {
  973. print $stickyResponse;
  974. print "Clear-static-directory $thisRemoteDir/\n";
  975. print "$thisRepoDir/\n";
  976. print $stickyResponse; # yes, twice
  977. print "Template $thisRemoteDir/\n";
  978. print "$thisRepoDir/\n";
  979. print "0\n";
  980. }
  981. $seendirs->{$dir} = 1;
  982. # FUTURE: This would more accurately emulate CVS by sending
  983. # another copy of sticky after processing the files in that
  984. # directory. Or intermediate: perhaps send all sticky's for
  985. # $seendirs after processing all files.
  986. }
  987. # update \n
  988. # Response expected: yes. Actually do a cvs update command. This uses any
  989. # previous Argument, Directory, Entry, or Modified requests, if they have
  990. # been sent. The last Directory sent specifies the working directory at the
  991. # time of the operation. The -I option is not used--files which the client
  992. # can decide whether to ignore are not mentioned and the client sends the
  993. # Questionable request for others.
  994. sub req_update
  995. {
  996. my ( $cmd, $data ) = @_;
  997. $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
  998. argsplit("update");
  999. #
  1000. # It may just be a client exploring the available heads/modules
  1001. # in that case, list them as top level directories and leave it
  1002. # at that. Eclipse uses this technique to offer you a list of
  1003. # projects (heads in this case) to checkout.
  1004. #
  1005. if ($state->{module} eq '') {
  1006. my $showref = safe_pipe_capture(qw(git show-ref --heads));
  1007. print "E cvs update: Updating .\n";
  1008. for my $line (split '\n', $showref) {
  1009. if ( $line =~ m% refs/heads/(.*)$% ) {
  1010. print "E cvs update: New directory `$1'\n";
  1011. }
  1012. }
  1013. print "ok\n";
  1014. return 1;
  1015. }
  1016. # Grab a handle to the SQLite db and do any necessary updates
  1017. my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
  1018. $updater->update();
  1019. argsfromdir($updater);
  1020. #$log->debug("update state : " . Dumper($state));
  1021. my($repoDir);
  1022. $repoDir=$state->{CVSROOT} . "/$state->{module}/$state->{prependdir}";
  1023. my %seendirs = ();
  1024. # foreach file specified on the command line ...
  1025. foreach my $argsFilename ( @{$state->{args}} )
  1026. {
  1027. my $filename;
  1028. $filename = filecleanup($argsFilename);
  1029. $log->debug("Processing file $filename");
  1030. # if we have a -C we should pretend we never saw modified stuff
  1031. if ( exists ( $state->{opt}{C} ) )
  1032. {
  1033. delete $state->{entries}{$filename}{modified_hash};
  1034. delete $state->{entries}{$filename}{modified_filename};
  1035. $state->{entries}{$filename}{unchanged} = 1;
  1036. }
  1037. my $stickyInfo = resolveStickyInfo($filename,
  1038. $state->{opt}{r},
  1039. $state->{opt}{D},
  1040. exists($state->{opt}{A}));
  1041. my $meta = $updater->getmeta($filename, $stickyInfo);
  1042. # If -p was given, "print" the contents of the requested revision.
  1043. if ( exists ( $state->{opt}{p} ) ) {
  1044. if ( defined ( $meta->{revision} ) ) {
  1045. $log->info("Printing '$filename' revision " . $meta->{revision});
  1046. transmitfile($meta->{filehash}, { print => 1 });
  1047. }
  1048. next;
  1049. }
  1050. # Directories:
  1051. prepDirForOutput(
  1052. dirname($argsFilename),
  1053. $repoDir,
  1054. ".",
  1055. \%seendirs,
  1056. "update",
  1057. $state->{dirArgs} );
  1058. my $wrev = revparse($filename);
  1059. if ( ! defined $meta )
  1060. {
  1061. $meta = {
  1062. name => $filename,
  1063. revision => '0',
  1064. filehash => 'added'
  1065. };
  1066. if($wrev ne "0")
  1067. {
  1068. $meta->{filehash}='deleted';
  1069. }
  1070. }
  1071. my $oldmeta = $meta;
  1072. # If the working copy is an old revision, lets get that version too for comparison.
  1073. my $oldWrev=$wrev;
  1074. if(defined($oldWrev))
  1075. {
  1076. $oldWrev=~s/^-//;
  1077. if($oldWrev ne $meta->{revision})
  1078. {
  1079. $oldmeta = $updater->getmeta($filename, $oldWrev);
  1080. }
  1081. }
  1082. #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
  1083. # Files are up to date if the working copy and repo copy have the same revision,
  1084. # and the working copy is unmodified _and_ the user hasn't specified -C
  1085. next if ( defined ( $wrev )
  1086. and defined($meta->{revision})
  1087. and $wrev eq $meta->{revision}
  1088. and $state->{entries}{$filename}{unchanged}
  1089. and not exists ( $state->{opt}{C} ) );
  1090. # If the working copy and repo copy have the same revision,
  1091. # but the working copy is modified, tell the client it's modified
  1092. if ( defined ( $wrev )
  1093. and defined($meta->{revision})
  1094. and $wrev eq $meta->{revision}
  1095. and $wrev ne "0"
  1096. and defined($state->{entries}{$filename}{modified_hash})
  1097. and not exists ( $state->{opt}{C} ) )
  1098. {
  1099. $log->info("Tell the client the file is modified");
  1100. print "MT text M \n";
  1101. print "MT fname $filename\n";
  1102. print "MT newline\n";
  1103. next;
  1104. }
  1105. if ( $meta->{filehash} eq "deleted" && $wrev ne "0" )
  1106. {
  1107. # TODO: If it has been modified in the sandbox, error out
  1108. # with the appropriate message, rather than deleting a modified
  1109. # file.
  1110. my ( $filepart, $dirpart ) = filenamesplit($filename,1);
  1111. $log->info("Removing '$filename' from working copy (no longer in the repo)");
  1112. print "E cvs update: `$filename' is no longer in the repository\n";
  1113. # Don't want to actually _DO_ the update if -n specified
  1114. unless ( $state->{globaloptions}{-n} ) {
  1115. print "Removed $dirpart\n";
  1116. print "$filepart\n";
  1117. }
  1118. }
  1119. elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
  1120. or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
  1121. or $meta->{filehash} eq 'added' )
  1122. {
  1123. # normal update, just send the new revision (either U=Update,
  1124. # or A=Add, or R=Remove)
  1125. if ( defined($wrev) && ($wrev=~/^-/) )
  1126. {
  1127. $log->info("Tell the client the file is scheduled for removal");
  1128. print "MT text R \n";
  1129. print "MT fname $filename\n";
  1130. print "MT newline\n";
  1131. next;
  1132. }
  1133. elsif ( (!defined($wrev) || $wrev eq '0') &&
  1134. (!defined($meta->{revision}) || $meta->{revision} eq '0') )
  1135. {
  1136. $log->info("Tell the client the file is scheduled for addition");
  1137. print "MT text A \n";
  1138. print "MT fname $filename\n";
  1139. print "MT newline\n";
  1140. next;
  1141. }
  1142. else {
  1143. $log->info("UpdatingX3 '$filename' to ".$meta->{revision});
  1144. print "MT +updated\n";
  1145. print "MT text U \n";
  1146. print "MT fname $filename\n";
  1147. print "MT newline\n";
  1148. print "MT -updated\n";
  1149. }
  1150. my ( $filepart, $dirpart ) = filenamesplit($filename,1);
  1151. # Don't want to actually _DO_ the update if -n specified
  1152. unless ( $state->{globaloptions}{-n} )
  1153. {
  1154. if ( defined ( $wrev ) )
  1155. {
  1156. # instruct client we're sending a file to put in this path as a replacement
  1157. print "Update-existing $dirpart\n";
  1158. $log->debug("Updating existing file 'Update-existing $dirpart'");
  1159. } else {
  1160. # instruct client we're sending a file to put in this path as a new file
  1161. $log->debug("Creating new file 'Created $dirpart'");
  1162. print "Created $dirpart\n";
  1163. }
  1164. print $state->{CVSROOT} . "/$state->{module}/$filename\n";
  1165. # this is an "entries" line
  1166. my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
  1167. my $entriesLine = "/$filepart/$meta->{revision}//$kopts/";
  1168. $entriesLine .= getStickyTagOrDate($stickyInfo);
  1169. $log->debug($entriesLine);
  1170. print "$entriesLine\n";
  1171. # permissions
  1172. $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
  1173. print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
  1174. # transmit file
  1175. transmitfile($meta->{filehash});
  1176. }
  1177. } else {
  1178. my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
  1179. my $mergeDir = setupTmpDir();
  1180. my $file_local = $filepart . ".mine";
  1181. my $mergedFile = "$mergeDir/$file_local";
  1182. system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
  1183. my $file_old = $filepart . "." . $oldmeta->{revision};
  1184. transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
  1185. my $file_new = $filepart . "." . $meta->{revision};
  1186. transmitfile($meta->{filehash}, { targetfile => $file_new });
  1187. # we need to merge with the local changes ( M=successful merge, C=conflict merge )
  1188. $log->info("Merging $file_local, $file_old, $file_new");
  1189. print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
  1190. $log->debug("Temporary directory for merge is $mergeDir");
  1191. my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
  1192. $return >>= 8;
  1193. cleanupTmpDir();
  1194. if ( $return == 0 )
  1195. {
  1196. $log->info("Merged successfully");
  1197. print "M M $filename\n";
  1198. $log->debug("Merged $dirpart");
  1199. # Don't want to actually _DO_ the update if -n specified
  1200. unless ( $state->{globaloptions}{-n} )
  1201. {
  1202. print "Merged $dirpart\n";
  1203. $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
  1204. print $state->{CVSROOT} . "/$state->{module}/$filename\n";
  1205. my $kopts = kopts_from_path("$dirpart/$filepart",
  1206. "file",$mergedFile);
  1207. $log->debug("/$filepart/$meta->{revision}//$kopts/");
  1208. my $entriesLine="/$filepart/$meta->{revision}//$kopts/";
  1209. $entriesLine .= getStickyTagOrDate($stickyInfo);
  1210. print "$entriesLine\n";
  1211. }
  1212. }
  1213. elsif ( $return == 1 )
  1214. {
  1215. $log->info("Merged with conflicts");
  1216. print "E cvs update: conflicts found in $filename\n";
  1217. print "M C $filename\n";
  1218. # Don't want to actually _DO_ the update if -n specified
  1219. unless ( $state->{globaloptions}{-n} )
  1220. {
  1221. print "Merged $dirpart\n";
  1222. print $state->{CVSROOT} . "/$state->{module}/$filename\n";
  1223. my $kopts = kopts_from_path("$dirpart/$filepart",
  1224. "file",$mergedFile);
  1225. my $entriesLine = "/$filepart/$meta->{revision}/+/$kopts/";
  1226. $entriesLine .= getStickyTagOrDate($stickyInfo);
  1227. print "$entriesLine\n";
  1228. }
  1229. }
  1230. else
  1231. {
  1232. $log->warn("Merge failed");
  1233. next;
  1234. }
  1235. # Don't want to actually _DO_ the update if -n specified
  1236. unless ( $state->{globaloptions}{-n} )
  1237. {
  1238. # permissions
  1239. $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
  1240. print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
  1241. # transmit file, format is single integer on a line by itself (file
  1242. # size) followed by the file contents
  1243. # TODO : we should copy files in blocks
  1244. my $data = safe_pipe_capture('cat', $mergedFile);
  1245. $log->debug("File size : " . length($data));
  1246. print length($data) . "\n";
  1247. print $data;
  1248. }
  1249. }
  1250. }
  1251. # prepDirForOutput() any other existing directories unless they already
  1252. # have the right sticky tag:
  1253. unless ( $state->{globaloptions}{n} )
  1254. {
  1255. my $dir;
  1256. foreach $dir (keys(%{$state->{dirMap}}))
  1257. {
  1258. if( ! $seendirs{$dir} &&
  1259. exists($state->{dirArgs}{$dir}) )
  1260. {
  1261. my($oldTag);
  1262. $oldTag=$state->{dirMap}{$dir}{tagspec};
  1263. unless( ( exists($state->{opt}{A}) &&
  1264. defined($oldTag) ) ||
  1265. ( defined($state->{opt}{r}) &&
  1266. ( !defined($oldTag) ||
  1267. $state->{opt}{r} ne $oldTag ) ) )
  1268. # TODO?: OR sticky dir is different...
  1269. {
  1270. next;
  1271. }
  1272. prepDirForOutput(
  1273. $dir,
  1274. $repoDir,
  1275. ".",
  1276. \%seendirs,
  1277. 'update',
  1278. $state->{dirArgs} );
  1279. }
  1280. # TODO?: Consider sending a final duplicate Sticky response
  1281. # to more closely mimic real CVS.
  1282. }
  1283. }
  1284. print "ok\n";
  1285. }
  1286. sub req_ci
  1287. {
  1288. my ( $cmd, $data ) = @_;
  1289. argsplit("ci");
  1290. #$log->debug("State : " . Dumper($state));
  1291. $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
  1292. if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
  1293. {
  1294. print "error 1 anonymous user cannot commit via pserver\n";
  1295. cleanupWorkTree();
  1296. exit;
  1297. }
  1298. if ( -e $state->{CVSROOT} . "/index" )
  1299. {
  1300. $log->warn("file 'index' already exists in the git repository");
  1301. print "error 1 Index already exists in git repo\n";
  1302. cleanupWorkTree();
  1303. exit;
  1304. }
  1305. # Grab a handle to the SQLite db and do any necessary updates
  1306. my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
  1307. $updater->update();
  1308. my @committedfiles = ();
  1309. my %oldmeta;
  1310. my $stickyInfo;
  1311. my $branchRef;
  1312. my $parenthash;
  1313. # foreach file specified on the command line ...
  1314. foreach my $filename ( @{$state->{args}} )
  1315. {
  1316. my $committedfile = $filename;
  1317. $filename = filecleanup($filename);
  1318. next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
  1319. #####
  1320. # Figure out which branch and parenthash we are committing
  1321. # to, and setup worktree:
  1322. # should always come from entries:
  1323. my $fileStickyInfo = resolveStickyInfo($filename);
  1324. if( !defined($branchRef) )
  1325. {
  1326. $stickyInfo = $fileStickyInfo;
  1327. if( defined($stickyInfo) &&
  1328. ( defined($stickyInfo->{date}) ||
  1329. !defined($stickyInfo->{tag}) ) )
  1330. {
  1331. print "error 1 cannot commit with sticky date for file `$filename'\n";
  1332. cleanupWorkTree();
  1333. exit;
  1334. }
  1335. $branchRef = "refs/heads/$state->{module}";
  1336. if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
  1337. {
  1338. $branchRef = "refs/heads/$stickyInfo->{tag}";
  1339. }
  1340. $parenthash = safe_pipe_capture('git', 'show-ref', '-s', $branchRef);
  1341. chomp $parenthash;
  1342. if ($parenthash !~ /^[0-9a-f]{$state->{hexsz}}$/)
  1343. {
  1344. if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
  1345. {
  1346. print "error 1 sticky tag `$stickyInfo->{tag}' for file `$filename' is not a branch\n";
  1347. }
  1348. else
  1349. {
  1350. print "error 1 pserver cannot find the current HEAD of module";
  1351. }
  1352. cleanupWorkTree();
  1353. exit;
  1354. }
  1355. setupWorkTree($parenthash);
  1356. $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
  1357. $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
  1358. }
  1359. elsif( !refHashEqual($stickyInfo,$fileStickyInfo) )
  1360. {
  1361. #TODO: We could split the cvs commit into multiple
  1362. # git commits by distinct stickyTag values, but that
  1363. # is lowish priority.
  1364. print "error 1 Committing different files to different"
  1365. . " branches is not currently supported\n";
  1366. cleanupWorkTree();
  1367. exit;
  1368. }
  1369. #####
  1370. # Process this file:
  1371. my $meta = $updater->getmeta($filename,$stickyInfo);
  1372. $oldmeta{$filename} = $meta;
  1373. my $wrev = revparse($filename);
  1374. my ( $filepart, $dirpart ) = filenamesplit($filename);
  1375. # do a checkout of the file if it is part of this tree
  1376. if ($wrev) {
  1377. system('git', 'checkout-index', '-f', '-u', $filename);
  1378. unless ($? == 0) {
  1379. die "Error running git-checkout-index -f -u $filename : $!";
  1380. }
  1381. }
  1382. my $addflag = 0;
  1383. my $rmflag = 0;
  1384. $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
  1385. $addflag = 1 unless ( -e $filename );
  1386. # Do up to date checking
  1387. unless ( $addflag or $wrev eq $meta->{revision} or
  1388. ( $rmflag and $wrev eq "-$meta->{revision}" ) )
  1389. {
  1390. # fail everything if an up to date check fails
  1391. print "error 1 Up to date check failed for $filename\n";
  1392. cleanupWorkTree();
  1393. exit;
  1394. }
  1395. push @committedfiles, $committedfile;
  1396. $log->info("Committing $filename");
  1397. system("mkdir","-p",$dirpart) unless ( -d $dirpart );
  1398. unless ( $rmflag )
  1399. {
  1400. $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
  1401. rename $state->{entries}{$filename}{modified_filename},$filename;
  1402. # Calculate modes to remove
  1403. my $invmode = "";
  1404. foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
  1405. $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
  1406. system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
  1407. }
  1408. if ( $rmflag )
  1409. {
  1410. $log->info("Removing file '$filename'");
  1411. unlink($filename);
  1412. system("git", "update-index", "--remove", $filename);
  1413. }
  1414. elsif ( $addflag )
  1415. {
  1416. $log->info("Adding file '$filename'");
  1417. system("git", "update-index", "--add", $filename);
  1418. } else {
  1419. $log->info("UpdatingX2 file '$filename'");
  1420. system("git", "update-index", $filename);
  1421. }
  1422. }
  1423. unless ( scalar(@committedfiles) > 0 )
  1424. {
  1425. print "E No files to commit\n";
  1426. print "ok\n";
  1427. cleanupWorkTree();
  1428. return;
  1429. }
  1430. my $treehash = safe_pipe_capture(qw(git write-tree));
  1431. chomp $treehash;
  1432. $log->debug("Treehash : $treehash, Parenthash : $parenthash");
  1433. # write our commit message out if we have one ...
  1434. my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
  1435. print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
  1436. if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
  1437. if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
  1438. print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
  1439. }
  1440. } else {
  1441. print $msg_fh "\n\nvia git-CVS emulator\n";
  1442. }
  1443. close $msg_fh;
  1444. my $commithash = safe_pipe_capture('git', 'commit-tree', $treehash, '-p', $parenthash, '-F', $msg_filename);
  1445. chomp($commithash);
  1446. $log->info("Commit hash : $commithash");
  1447. unless ( $commithash =~ /[a-zA-Z0-9]{$state->{hexsz}}/ )
  1448. {
  1449. $log->warn("Commit failed (Invalid commit hash)");
  1450. print "error 1 Commit failed (unknown reason)\n";
  1451. cleanupWorkTree();
  1452. exit;
  1453. }
  1454. ### Emulate git-receive-pack by running hooks/update
  1455. my @hook = ( $ENV{GIT_DIR}.'hooks/update', $branchRef,
  1456. $parenthash, $commithash );
  1457. if( -x $hook[0] ) {
  1458. unless( system( @hook ) == 0 )
  1459. {
  1460. $log->warn("Commit failed (update hook declined to update ref)");
  1461. print "error 1 Commit failed (update hook declined)\n";
  1462. cleanupWorkTree();
  1463. exit;
  1464. }
  1465. }
  1466. ### Update the ref
  1467. if (system(qw(git update-ref -m), "cvsserver ci",
  1468. $branchRef, $commithash, $parenthash)) {
  1469. $log->warn("update-ref for $state->{module} failed.");
  1470. print "error 1 Cannot commit -- update first\n";
  1471. cleanupWorkTree();
  1472. exit;
  1473. }
  1474. ### Emulate git-receive-pack by running hooks/post-receive
  1475. my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
  1476. if( -x $hook ) {
  1477. open(my $pipe, "| $hook") || die "can't fork $!";
  1478. local $SIG{PIPE} = sub { die 'pipe broke' };
  1479. print $pipe "$parenthash $commithash $branchRef\n";
  1480. close $pipe || die "bad pipe: $! $?";
  1481. }
  1482. $updater->update();
  1483. ### Then hooks/post-update
  1484. $hook = $ENV{GIT_DIR}.'hooks/post-update';
  1485. if (-x $hook) {
  1486. system($hook, $branchRef);
  1487. }
  1488. # foreach file specified on the command line ...
  1489. foreach my $filename ( @committedfiles )
  1490. {
  1491. $filename = filecleanup($filename);
  1492. my $meta = $updater->getmeta($filename,$stickyInfo);
  1493. unless (defined $meta->{revision}) {
  1494. $meta->{revision} = "1.1";
  1495. }
  1496. my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
  1497. $log->debug("Checked-in $dirpart : $filename");
  1498. print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
  1499. if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
  1500. {
  1501. print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
  1502. print "Remove-entry $dirpart\n";
  1503. print "$filename\n";
  1504. } else {
  1505. if ($meta->{revision} eq "1.1") {
  1506. print "M initial revision: 1.1\n";
  1507. } else {
  1508. print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
  1509. }
  1510. print "Checked-in $dirpart\n";
  1511. print "$filename\n";
  1512. my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
  1513. print "/$filepart/$meta->{revision}//$kopts/" .
  1514. getStickyTagOrDate($stickyInfo) . "\n";
  1515. }
  1516. }
  1517. cleanupWorkTree();
  1518. print "ok\n";
  1519. }
  1520. sub req_status
  1521. {
  1522. my ( $cmd, $data ) = @_;
  1523. argsplit("status");
  1524. $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
  1525. #$log->debug("status state : " . Dumper($state));
  1526. # Grab a handle to the SQLite db and do any necessary updates
  1527. my $updater;
  1528. $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
  1529. $updater->update();
  1530. # if no files were specified, we need to work out what files we should
  1531. # be providing status on ...
  1532. argsfromdir($updater);
  1533. # foreach file specified on the command line ...
  1534. foreach my $filename ( @{$state->{args}} )
  1535. {
  1536. $filename = filecleanup($filename);
  1537. if ( exists($state->{opt}{l}) &&
  1538. index($filename, '/', length($state->{prependdir})) >= 0 )
  1539. {
  1540. next;
  1541. }
  1542. my $wrev = revparse($filename);
  1543. my $stickyInfo = resolveStickyInfo($filename);
  1544. my $meta = $updater->getmeta($filename,$stickyInfo);
  1545. my $oldmeta = $meta;
  1546. # If the working copy is an old revision, lets get that
  1547. # version too for comparison.
  1548. if ( defined($wrev) and $wrev ne $meta->{revision} )
  1549. {
  1550. my($rmRev)=$wrev;
  1551. $rmRev=~s/^-//;
  1552. $oldmeta = $updater->getmeta($filename, $rmRev);
  1553. }
  1554. # TODO : All possible statuses aren't yet implemented
  1555. my $status;
  1556. # Files are up to date if the working copy and repo copy have
  1557. # the same revision, and the working copy is unmodified
  1558. if ( defined ( $wrev ) and defined($meta->{revision}) and
  1559. $wrev eq $meta->{revision} and
  1560. ( ( $state->{entries}{$filename}{unchanged} and
  1561. ( not defined ( $state->{entries}{$filename}{conflict} ) or
  1562. $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or
  1563. ( defined($state->{entries}{$filename}{modified_hash}) and
  1564. $state->{entries}{$filename}{modified_hash} eq
  1565. $meta->{filehash} ) ) )
  1566. {
  1567. $status = "Up-to-date"
  1568. }
  1569. # Need checkout if the working copy has a different (usually
  1570. # older) revision than the repo copy, and the working copy is
  1571. # unmodified
  1572. if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
  1573. $meta->{revision} ne $wrev and
  1574. ( $state->{entries}{$filename}{unchanged} or
  1575. ( defined($state->{entries}{$filename}{modified_hash}) and
  1576. $state->{entries}{$filename}{modified_hash} eq
  1577. $oldmeta->{filehash} ) ) )
  1578. {
  1579. $status ||= "Needs Checkout";
  1580. }
  1581. # Need checkout if it exists in the repo but doesn't have a working
  1582. # copy
  1583. if ( not defined ( $wrev ) and defined ( $meta->{revision} ) )
  1584. {
  1585. $status ||= "Needs Checkout";
  1586. }
  1587. # Locally modified if working copy and repo copy have the
  1588. # same revision but there are local changes
  1589. if ( defined ( $wrev ) and defined($meta->{revision}) and
  1590. $wrev eq $meta->{revision} and
  1591. $wrev ne "0" and
  1592. $state->{entries}{$filename}{modified_filename} )
  1593. {
  1594. $status ||= "Locally Modified";
  1595. }
  1596. # Needs Merge if working copy revision is different
  1597. # (usually older) than repo copy and there are local changes
  1598. if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
  1599. $meta->{revision} ne $wrev and
  1600. $state->{entries}{$filename}{modified_filename} )
  1601. {
  1602. $status ||= "Needs Merge";
  1603. }
  1604. if ( defined ( $state->{entries}{$filename}{revision} ) and
  1605. ( !defined($meta->{revision}) ||
  1606. $meta->{revision} eq "0" ) )
  1607. {
  1608. $status ||= "Locally Added";
  1609. }
  1610. if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
  1611. $wrev eq "-$meta->{revision}" )
  1612. {
  1613. $status ||= "Locally Removed";
  1614. }
  1615. if ( defined ( $state->{entries}{$filename}{conflict} ) and
  1616. $state->{entries}{$filename}{conflict} =~ /^\+=/ )
  1617. {
  1618. $status ||= "Unresolved Conflict";
  1619. }
  1620. if ( 0 )
  1621. {
  1622. $status ||= "File had conflicts on merge";
  1623. }
  1624. $status ||= "Unknown";
  1625. my ($filepart) = filenamesplit($filename);
  1626. print "M =======" . ( "=" x 60 ) . "\n";
  1627. print "M File: $filepart\tStatus: $status\n";
  1628. if ( defined($state->{entries}{$filename}{revision}) )
  1629. {
  1630. print "M Working revision:\t" .
  1631. $state->{entries}{$filename}{revision} . "\n";
  1632. } else {
  1633. print "M Working revision:\tNo entry for $filename\n";
  1634. }
  1635. if ( defined($meta->{revision}) )
  1636. {
  1637. print "M Repository revision:\t" .
  1638. $meta->{revision} .
  1639. "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
  1640. my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
  1641. my($tag)=($tagOrDate=~m/^T(.+)$/);
  1642. if( !defined($tag) )
  1643. {
  1644. $tag="(none)";
  1645. }
  1646. print "M Sticky Tag:\t\t$tag\n";
  1647. my($date)=($tagOrDate=~m/^D(.+)$/);
  1648. if( !defined($date) )
  1649. {
  1650. $date="(none)";
  1651. }
  1652. print "M Sticky Date:\t\t$date\n";
  1653. my($options)=$state->{entries}{$filename}{options};
  1654. if( $options eq "" )
  1655. {
  1656. $options="(none)";
  1657. }
  1658. print "M Sticky Options:\t\t$options\n";
  1659. } else {
  1660. print "M Repository revision:\tNo revision control file\n";
  1661. }
  1662. print "M\n";
  1663. }
  1664. print "ok\n";
  1665. }
  1666. sub req_diff
  1667. {
  1668. my ( $cmd, $data ) = @_;
  1669. argsplit("diff");
  1670. $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
  1671. #$log->debug("status state : " . Dumper($state));
  1672. my ($revision1, $revision2);
  1673. if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
  1674. {
  1675. $revision1 = $state->{opt}{r}[0];
  1676. $revision2 = $state->{opt}{r}[1];
  1677. } else {
  1678. $revision1 = $state->{opt}{r};
  1679. }
  1680. $log->debug("Diffing revisions " .
  1681. ( defined($revision1) ? $revision1 : "[NULL]" ) .
  1682. " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
  1683. # Grab a handle to the SQLite db and do any necessary updates
  1684. my $updater;
  1685. $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
  1686. $updater->update();
  1687. # if no files were specified, we need to work out what files we should
  1688. # be providing status on ...
  1689. argsfromdir($updater);
  1690. my($foundDiff);
  1691. # foreach file specified on the command line ...
  1692. foreach my $argFilename ( @{$state->{args}} )
  1693. {
  1694. my($filename) = filecleanup($argFilename);
  1695. my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
  1696. my $wrev = revparse($filename);
  1697. # Priority for revision1:
  1698. # 1. First -r (missing file: check -N)
  1699. # 2. wrev from client's Entry line
  1700. # - missing line/file: check -N
  1701. # - "0": added file not committed (empty contents for rev1)
  1702. # - Prefixed with dash (to be removed): check -N
  1703. if ( defined ( $revision1 ) )
  1704. {
  1705. $meta1 = $updater->getmeta($filename, $revision1);
  1706. }
  1707. elsif( defined($wrev) && $wrev ne "0" )
  1708. {
  1709. my($rmRev)=$wrev;
  1710. $rmRev=~s/^-//;
  1711. $meta1 = $updater->getmeta($filename, $rmRev);
  1712. }
  1713. if ( !defined($meta1) ||
  1714. $meta1->{filehash} eq "deleted" )
  1715. {
  1716. if( !exists($state->{opt}{N}) )
  1717. {
  1718. if(!defined($revision1))
  1719. {
  1720. print "E File $filename at revision $revision1 doesn't exist\n";
  1721. }
  1722. next;
  1723. }
  1724. elsif( !defined($meta1) )
  1725. {
  1726. $meta1 = {
  1727. name => $filename,
  1728. revision => '0',
  1729. filehash => 'deleted'
  1730. };
  1731. }
  1732. }
  1733. # Priority for revision2:
  1734. # 1. Second -r (missing file: check -N)
  1735. # 2. Modified file contents from client
  1736. # 3. wrev from client's Entry line
  1737. # - missing line/file: check -N
  1738. # - Prefixed with dash (to be removed): check -N
  1739. # if we have a second -r switch, use it too
  1740. if ( defined ( $revision2 ) )
  1741. {
  1742. $meta2 = $updater->getmeta($filename, $revision2);
  1743. }
  1744. elsif(defined($state->{entries}{$filename}{modified_filename}))
  1745. {
  1746. $file2 = $state->{entries}{$filename}{modified_filename};
  1747. $meta2 = {
  1748. name => $filename,
  1749. revision => '0',
  1750. filehash => 'modified'
  1751. };
  1752. }
  1753. elsif( defined($wrev) && ($wrev!~/^-/) )
  1754. {
  1755. if(!defined($revision1)) # no revision and no modifications:
  1756. {
  1757. next;
  1758. }
  1759. $meta2 = $updater->getmeta($filename, $wrev);
  1760. }
  1761. if(!defined($file2))
  1762. {
  1763. if ( !defined($meta2) ||
  1764. $meta2->{filehash} eq "deleted" )
  1765. {
  1766. if( !exists($state->{opt}{N}) )
  1767. {
  1768. if(!defined($revision2))
  1769. {
  1770. print "E File $filename at revision $revision2 doesn't exist\n";
  1771. }
  1772. next;
  1773. }
  1774. elsif( !defined($meta2) )
  1775. {
  1776. $meta2 = {
  1777. name => $filename,
  1778. revision => '0',
  1779. filehash => 'deleted'
  1780. };
  1781. }
  1782. }
  1783. }
  1784. if( $meta1->{filehash} eq $meta2->{filehash} )
  1785. {
  1786. $log->info("unchanged $filename");
  1787. next;
  1788. }
  1789. # Retrieve revision contents:
  1790. ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
  1791. transmitfile($meta1->{filehash}, { targetfile => $file1 });
  1792. if(!defined($file2))
  1793. {
  1794. ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
  1795. transmitfile($meta2->{filehash}, { targetfile => $file2 });
  1796. }
  1797. # Generate the actual diff:
  1798. print "M Index: $argFilename\n";
  1799. print "M =======" . ( "=" x 60 ) . "\n";
  1800. print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
  1801. if ( defined ( $meta1 ) && $meta1->{revision} ne "0" )
  1802. {
  1803. print "M retrieving revision $meta1->{revision}\n"
  1804. }
  1805. if ( defined ( $meta2 ) && $meta2->{revision} ne "0" )
  1806. {
  1807. print "M retrieving revision $meta2->{revision}\n"
  1808. }
  1809. print "M diff ";
  1810. foreach my $opt ( sort keys %{$state->{opt}} )
  1811. {
  1812. if ( ref $state->{opt}{$opt} eq "ARRAY" )
  1813. {
  1814. foreach my $value ( @{$state->{opt}{$opt}} )
  1815. {
  1816. print "-$opt $value ";
  1817. }
  1818. } else {
  1819. print "-$opt ";
  1820. if ( defined ( $state->{opt}{$opt} ) )
  1821. {
  1822. print "$state->{opt}{$opt} "
  1823. }
  1824. }
  1825. }
  1826. print "$argFilename\n";
  1827. $log->info("Diffing $filename -r $meta1->{revision} -r " .
  1828. ( $meta2->{revision} or "workingcopy" ));
  1829. # TODO: Use --label instead of -L because -L is no longer
  1830. # documented and may go away someday. Not sure if there there are
  1831. # versions that only support -L, which would make this change risky?
  1832. # http://osdir.com/ml/bug-gnu-utils-gnu/2010-12/msg00060.html
  1833. # ("man diff" should actually document the best migration strategy,
  1834. # [current behavior, future changes, old compatibility issues
  1835. # or lack thereof, etc], not just stop mentioning the option...)
  1836. # TODO: Real CVS seems to include a date in the label, before
  1837. # the revision part, without the keyword "revision". The following
  1838. # has minimal changes compared to original versions of
  1839. # git-cvsserver.perl. (Mostly tab vs space after filename.)
  1840. my (@diffCmd) = ( 'diff' );
  1841. if ( exists($state->{opt}{N}) )
  1842. {
  1843. push @diffCmd,"-N";
  1844. }
  1845. if ( exists $state->{opt}{u} )
  1846. {
  1847. push @diffCmd,("-u","-L");
  1848. if( $meta1->{filehash} eq "deleted" )
  1849. {
  1850. push @diffCmd,"/dev/null";
  1851. } else {
  1852. push @diffCmd,("$argFilename\trevision $meta1->{revision}");
  1853. }
  1854. if( defined($meta2->{filehash}) )
  1855. {
  1856. if( $meta2->{filehash} eq "deleted" )
  1857. {
  1858. push @diffCmd,("-L","/dev/null");
  1859. } else {
  1860. push @diffCmd,("-L",
  1861. "$argFilename\trevision $meta2->{revision}");
  1862. }
  1863. } else {
  1864. push @diffCmd,("-L","$argFilename\tworking copy");
  1865. }
  1866. }
  1867. push @diffCmd,($file1,$file2);
  1868. if(!open(DIFF,"-|",@diffCmd))
  1869. {
  1870. $log->warn("Unable to run diff: $!");
  1871. }
  1872. my($diffLine);
  1873. while(defined($diffLine=<DIFF>))
  1874. {
  1875. print "M $diffLine";
  1876. $foundDiff=1;
  1877. }
  1878. close(DIFF);
  1879. }
  1880. if($foundDiff)
  1881. {
  1882. print "error \n";
  1883. }
  1884. else
  1885. {
  1886. print "ok\n";
  1887. }
  1888. }
  1889. sub req_log
  1890. {
  1891. my ( $cmd, $data ) = @_;
  1892. argsplit("log");
  1893. $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
  1894. #$log->debug("log state : " . Dumper($state));
  1895. my ( $revFilter );
  1896. if ( defined ( $state->{opt}{r} ) )
  1897. {
  1898. $revFilter = $state->{opt}{r};
  1899. }
  1900. # Grab a handle to the SQLite db and do any necessary updates
  1901. my $updater;
  1902. $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
  1903. $updater->update();
  1904. # if no files were specified, we need to work out what files we
  1905. # should be providing status on ...
  1906. argsfromdir($updater);
  1907. # foreach file specified on the command line ...
  1908. foreach my $filename ( @{$state->{args}} )
  1909. {
  1910. $filename = filecleanup($filename);
  1911. my $headmeta = $updater->getmeta($filename);
  1912. my ($revisions,$totalrevisions) = $updater->getlog($filename,
  1913. $revFilter);
  1914. next unless ( scalar(@$revisions) );
  1915. print "M \n";
  1916. print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
  1917. print "M Working file: $filename\n";
  1918. print "M head: $headmeta->{revision}\n";
  1919. print "M branch:\n";
  1920. print "M locks: strict\n";
  1921. print "M access list:\n";
  1922. print "M symbolic names:\n";
  1923. print "M keyword substitution: kv\n";
  1924. print "M total revisions: $totalrevisions;\tselected revisions: " .
  1925. scalar(@$revisions) . "\n";
  1926. print "M description:\n";
  1927. foreach my $revision ( @$revisions )
  1928. {
  1929. print "M ----------------------------\n";
  1930. print "M revision $revision->{revision}\n";
  1931. # reformat the date for log output
  1932. if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
  1933. defined($DATE_LIST->{$2}) )
  1934. {
  1935. $revision->{modified} = sprintf('%04d/%02d/%02d %s',
  1936. $3, $DATE_LIST->{$2}, $1, $4 );
  1937. }
  1938. $revision->{author} = cvs_author($revision->{author});
  1939. print "M date: $revision->{modified};" .
  1940. " author: $revision->{author}; state: " .
  1941. ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) .
  1942. "; lines: +2 -3\n";
  1943. my $commitmessage;
  1944. $commitmessage = $updater->commitmessage($revision->{commithash});
  1945. $commitmessage =~ s/^/M /mg;
  1946. print $commitmessage . "\n";
  1947. }
  1948. print "M =======" . ( "=" x 70 ) . "\n";
  1949. }
  1950. print "ok\n";
  1951. }
  1952. sub req_annotate
  1953. {
  1954. my ( $cmd, $data ) = @_;
  1955. argsplit("annotate");
  1956. $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
  1957. #$log->debug("status state : " . Dumper($state));
  1958. # Grab a handle to the SQLite db and do any necessary updates
  1959. my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
  1960. $updater->update();
  1961. # if no files were specified, we need to work out what files we should be providing annotate on ...
  1962. argsfromdir($updater);
  1963. # we'll need a temporary checkout dir
  1964. setupWorkTree();
  1965. $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
  1966. # foreach file specified on the command line ...
  1967. foreach my $filename ( @{$state->{args}} )
  1968. {
  1969. $filename = filecleanup($filename);
  1970. my $meta = $updater->getmeta($filename);
  1971. next unless ( $meta->{revision} );
  1972. # get all the commits that this file was in
  1973. # in dense format -- aka skip dead revisions
  1974. my $revisions = $updater->gethistorydense($filename);
  1975. my $lastseenin = $revisions->[0][2];
  1976. # populate the temporary index based on the latest commit were we saw
  1977. # the file -- but do it cheaply without checking out any files
  1978. # TODO: if we got a revision from the client, use that instead
  1979. # to look up the commithash in sqlite (still good to default to
  1980. # the current head as we do now)
  1981. system("git", "read-tree", $lastseenin);
  1982. unless ($? == 0)
  1983. {
  1984. print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
  1985. return;
  1986. }
  1987. $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
  1988. # do a checkout of the file
  1989. system('git', 'checkout-index', '-f', '-u', $filename);
  1990. unless ($? == 0) {
  1991. print "E error running git-checkout-index -f -u $filename : $!\n";
  1992. return;
  1993. }
  1994. $log->info("Annotate $filename");
  1995. # Prepare a file with the commits from the linearized
  1996. # history that annotate should know about. This prevents
  1997. # git-jsannotate telling us about commits we are hiding
  1998. # from the client.
  1999. my $a_hints = "$work->{workDir}/.annotate_hints";
  2000. if (!open(ANNOTATEHINTS, '>', $a_hints)) {
  2001. print "E failed to open '$a_hints' for writing: $!\n";
  2002. return;
  2003. }
  2004. for (my $i=0; $i < @$revisions; $i++)
  2005. {
  2006. print ANNOTATEHINTS $revisions->[$i][2];
  2007. if ($i+1 < @$revisions) { # have we got a parent?
  2008. print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
  2009. }
  2010. print ANNOTATEHINTS "\n";
  2011. }
  2012. print ANNOTATEHINTS "\n";
  2013. close ANNOTATEHINTS
  2014. or (print "E failed to write $a_hints: $!\n"), return;
  2015. my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
  2016. if (!open(ANNOTATE, "-|", @cmd)) {
  2017. print "E error invoking ". join(' ',@cmd) .": $!\n";
  2018. return;
  2019. }
  2020. my $metadata = {};
  2021. print "E Annotations for $filename\n";
  2022. print "E ***************\n";
  2023. while ( <ANNOTATE> )
  2024. {
  2025. if (m/^([a-zA-Z0-9]{$state->{hexsz}})\t\([^\)]*\)(.*)$/i)
  2026. {
  2027. my $commithash = $1;
  2028. my $data = $2;
  2029. unless ( defined ( $metadata->{$commithash} ) )
  2030. {
  2031. $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
  2032. $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
  2033. $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
  2034. }
  2035. printf("M %-7s (%-8s %10s): %s\n",
  2036. $metadata->{$commithash}{revision},
  2037. $metadata->{$commithash}{author},
  2038. $metadata->{$commithash}{modified},
  2039. $data
  2040. );
  2041. } else {
  2042. $log->warn("Error in annotate output! LINE: $_");
  2043. print "E Annotate error \n";
  2044. next;
  2045. }
  2046. }
  2047. close ANNOTATE;
  2048. }
  2049. # done; get out of the tempdir
  2050. cleanupWorkTree();
  2051. print "ok\n";
  2052. }
  2053. # This method takes the state->{arguments} array and produces two new arrays.
  2054. # The first is $state->{args} which is everything before the '--' argument, and
  2055. # the second is $state->{files} which is everything after it.
  2056. sub argsplit
  2057. {
  2058. $state->{args} = [];
  2059. $state->{files} = [];
  2060. $state->{opt} = {};
  2061. return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
  2062. my $type = shift;
  2063. if ( defined($type) )
  2064. {
  2065. my $opt = {};
  2066. $opt = { A => 0, N => 0, P => 0, R => 0, c => 0, f => 0, l => 0, n => 0, p => 0, s => 0, r => 1, D => 1, d => 1, k => 1, j => 1, } if ( $type eq "co" );
  2067. $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
  2068. $opt = { A => 0, P => 0, C => 0, d => 0, f => 0, l => 0, R => 0, p => 0, k => 1, r => 1, D => 1, j => 1, I => 1, W => 1 } if ( $type eq "update" );
  2069. $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2, N => 0 } if ( $type eq "diff" );
  2070. $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
  2071. $opt = { k => 1, m => 1 } if ( $type eq "add" );
  2072. $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
  2073. $opt = { l => 0, b => 0, h => 0, R => 0, t => 0, N => 0, S => 0, r => 1, d => 1, s => 1, w => 1 } if ( $type eq "log" );
  2074. while ( scalar ( @{$state->{arguments}} ) > 0 )
  2075. {
  2076. my $arg = shift @{$state->{arguments}};
  2077. next if ( $arg eq "--" );
  2078. next unless ( $arg =~ /\S/ );
  2079. # if the argument looks like a switch
  2080. if ( $arg =~ /^-(\w)(.*)/ )
  2081. {
  2082. # if it's a switch that takes an argument
  2083. if ( $opt->{$1} )
  2084. {
  2085. # If this switch has already been provided
  2086. if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
  2087. {
  2088. $state->{opt}{$1} = [ $state->{opt}{$1} ];
  2089. if ( length($2) > 0 )
  2090. {
  2091. push @{$state->{opt}{$1}},$2;
  2092. } else {
  2093. push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
  2094. }
  2095. } else {
  2096. # if there's extra data in the arg, use that as the argument for the switch
  2097. if ( length($2) > 0 )
  2098. {
  2099. $state->{opt}{$1} = $2;
  2100. } else {
  2101. $state->{opt}{$1} = shift @{$state->{arguments}};
  2102. }
  2103. }
  2104. } else {
  2105. $state->{opt}{$1} = undef;
  2106. }
  2107. }
  2108. else
  2109. {
  2110. push @{$state->{args}}, $arg;
  2111. }
  2112. }
  2113. }
  2114. else
  2115. {
  2116. my $mode = 0;
  2117. foreach my $value ( @{$state->{arguments}} )
  2118. {
  2119. if ( $value eq "--" )
  2120. {
  2121. $mode++;
  2122. next;
  2123. }
  2124. push @{$state->{args}}, $value if ( $mode == 0 );
  2125. push @{$state->{files}}, $value if ( $mode == 1 );
  2126. }
  2127. }
  2128. }
  2129. # Used by argsfromdir
  2130. sub expandArg
  2131. {
  2132. my ($updater,$outNameMap,$outDirMap,$path,$isDir) = @_;
  2133. my $fullPath = filecleanup($path);
  2134. # Is it a directory?
  2135. if( defined($state->{dirMap}{$fullPath}) ||
  2136. defined($state->{dirMap}{"$fullPath/"}) )
  2137. {
  2138. # It is a directory in the user's sandbox.
  2139. $isDir=1;
  2140. if(defined($state->{entries}{$fullPath}))
  2141. {
  2142. $log->fatal("Inconsistent file/dir type");
  2143. die "Inconsistent file/dir type";
  2144. }
  2145. }
  2146. elsif(defined($state->{entries}{$fullPath}))
  2147. {
  2148. # It is a file in the user's sandbox.
  2149. $isDir=0;
  2150. }
  2151. my($revDirMap,$otherRevDirMap);
  2152. if(!defined($isDir) || $isDir)
  2153. {
  2154. # Resolve version tree for sticky tag:
  2155. # (for now we only want list of files for the version, not
  2156. # particular versions of those files: assume it is a directory
  2157. # for the moment; ignore Entry's stick tag)
  2158. # Order of precedence of sticky tags:
  2159. # -A [head]
  2160. # -r /tag/
  2161. # [file entry sticky tag, but that is only relevant to files]
  2162. # [the tag specified in dir req_Sticky]
  2163. # [the tag specified in a parent dir req_Sticky]
  2164. # [head]
  2165. # Also, -r may appear twice (for diff).
  2166. #
  2167. # FUTURE: When/if -j (merges) are supported, we also
  2168. # need to add relevant files from one or two
  2169. # versions specified with -j.
  2170. if(exists($state->{opt}{A}))
  2171. {
  2172. $revDirMap=$updater->getRevisionDirMap();
  2173. }
  2174. elsif( defined($state->{opt}{r}) and
  2175. ref $state->{opt}{r} eq "ARRAY" )
  2176. {
  2177. $revDirMap=$updater->getRevisionDirMap($state->{opt}{r}[0]);
  2178. $otherRevDirMap=$updater->getRevisionDirMap($state->{opt}{r}[1]);
  2179. }
  2180. elsif(defined($state->{opt}{r}))
  2181. {
  2182. $revDirMap=$updater->getRevisionDirMap($state->{opt}{r});
  2183. }
  2184. else
  2185. {
  2186. my($sticky)=getDirStickyInfo($fullPath);
  2187. $revDirMap=$updater->getRevisionDirMap($sticky->{tag});
  2188. }
  2189. # Is it a directory?
  2190. if( defined($revDirMap->{$fullPath}) ||
  2191. defined($otherRevDirMap->{$fullPath}) )
  2192. {
  2193. $isDir=1;
  2194. }
  2195. }
  2196. # What to do with it?
  2197. if(!$isDir)
  2198. {
  2199. $outNameMap->{$fullPath}=1;
  2200. }
  2201. else
  2202. {
  2203. $outDirMap->{$fullPath}=1;
  2204. if(defined($revDirMap->{$fullPath}))
  2205. {
  2206. addDirMapFiles($updater,$outNameMap,$outDirMap,
  2207. $revDirMap->{$fullPath});
  2208. }
  2209. if( defined($otherRevDirMap) &&
  2210. defined($otherRevDirMap->{$fullPath}) )
  2211. {
  2212. addDirMapFiles($updater,$outNameMap,$outDirMap,
  2213. $otherRevDirMap->{$fullPath});
  2214. }
  2215. }
  2216. }
  2217. # Used by argsfromdir
  2218. # Add entries from dirMap to outNameMap. Also recurse into entries
  2219. # that are subdirectories.
  2220. sub addDirMapFiles
  2221. {
  2222. my($updater,$outNameMap,$outDirMap,$dirMap)=@_;
  2223. my($fullName);
  2224. foreach $fullName (keys(%$dirMap))
  2225. {
  2226. my $cleanName=$fullName;
  2227. if(defined($state->{prependdir}))
  2228. {
  2229. if(!($cleanName=~s/^\Q$state->{prependdir}\E//))
  2230. {
  2231. $log->fatal("internal error stripping prependdir");
  2232. die "internal error stripping prependdir";
  2233. }
  2234. }
  2235. if($dirMap->{$fullName} eq "F")
  2236. {
  2237. $outNameMap->{$cleanName}=1;
  2238. }
  2239. elsif($dirMap->{$fullName} eq "D")
  2240. {
  2241. if(!$state->{opt}{l})
  2242. {
  2243. expandArg($updater,$outNameMap,$outDirMap,$cleanName,1);
  2244. }
  2245. }
  2246. else
  2247. {
  2248. $log->fatal("internal error in addDirMapFiles");
  2249. die "internal error in addDirMapFiles";
  2250. }
  2251. }
  2252. }
  2253. # This method replaces $state->{args} with a directory-expanded
  2254. # list of all relevant filenames (recursively unless -d), based
  2255. # on $state->{entries}, and the "current" list of files in
  2256. # each directory. "Current" files as determined by
  2257. # either the requested (-r/-A) or "req_Sticky" version of
  2258. # that directory.
  2259. # Both the input args and the new output args are relative
  2260. # to the cvs-client's CWD, although some of the internal
  2261. # computations are relative to the top of the project.
  2262. sub argsfromdir
  2263. {
  2264. my $updater = shift;
  2265. # Notes about requirements for specific callers:
  2266. # update # "standard" case (entries; a single -r/-A/default; -l)
  2267. # # Special case: -d for create missing directories.
  2268. # diff # 0 or 1 -r's: "standard" case.
  2269. # # 2 -r's: We could ignore entries (just use the two -r's),
  2270. # # but it doesn't really matter.
  2271. # annotate # "standard" case
  2272. # log # Punting: log -r has a more complex non-"standard"
  2273. # # meaning, and we don't currently try to support log'ing
  2274. # # branches at all (need a lot of work to
  2275. # # support CVS-consistent branch relative version
  2276. # # numbering).
  2277. #HERE: But we still want to expand directories. Maybe we should
  2278. # essentially force "-A".
  2279. # status # "standard", except that -r/-A/default are not possible.
  2280. # # Mostly only used to expand entries only)
  2281. #
  2282. # Don't use argsfromdir at all:
  2283. # add # Explicit arguments required. Directory args imply add
  2284. # # the directory itself, not the files in it.
  2285. # co # Obtain list directly.
  2286. # remove # HERE: TEST: MAYBE client does the recursion for us,
  2287. # # since it only makes sense to remove stuff already in
  2288. # # the sandbox?
  2289. # ci # HERE: Similar to remove...
  2290. # # Don't try to implement the confusing/weird
  2291. # # ci -r bug er.."feature".
  2292. if(scalar(@{$state->{args}})==0)
  2293. {
  2294. $state->{args} = [ "." ];
  2295. }
  2296. my %allArgs;
  2297. my %allDirs;
  2298. for my $file (@{$state->{args}})
  2299. {
  2300. expandArg($updater,\%allArgs,\%allDirs,$file);
  2301. }
  2302. # Include any entries from sandbox. Generally client won't
  2303. # send entries that shouldn't be used.
  2304. foreach my $file (keys %{$state->{entries}})
  2305. {
  2306. $allArgs{remove_prependdir($file)} = 1;
  2307. }
  2308. $state->{dirArgs} = \%allDirs;
  2309. $state->{args} = [
  2310. sort {
  2311. # Sort priority: by directory depth, then actual file name:
  2312. my @piecesA=split('/',$a);
  2313. my @piecesB=split('/',$b);
  2314. my $count=scalar(@piecesA);
  2315. my $tmp=scalar(@piecesB);
  2316. return $count<=>$tmp if($count!=$tmp);
  2317. for($tmp=0;$tmp<$count;$tmp++)
  2318. {
  2319. if($piecesA[$tmp] ne $piecesB[$tmp])
  2320. {
  2321. return $piecesA[$tmp] cmp $piecesB[$tmp]
  2322. }
  2323. }
  2324. return 0;
  2325. } keys(%allArgs) ];
  2326. }
  2327. ## look up directory sticky tag, of either fullPath or a parent:
  2328. sub getDirStickyInfo
  2329. {
  2330. my($fullPath)=@_;
  2331. $fullPath=~s%/+$%%;
  2332. while($fullPath ne "" && !defined($state->{dirMap}{"$fullPath/"}))
  2333. {
  2334. $fullPath=~s%/?[^/]*$%%;
  2335. }
  2336. if( !defined($state->{dirMap}{"$fullPath/"}) &&
  2337. ( $fullPath eq "" ||
  2338. $fullPath eq "." ) )
  2339. {
  2340. return $state->{dirMap}{""}{stickyInfo};
  2341. }
  2342. else
  2343. {
  2344. return $state->{dirMap}{"$fullPath/"}{stickyInfo};
  2345. }
  2346. }
  2347. # Resolve precedence of various ways of specifying which version of
  2348. # a file you want. Returns undef (for default head), or a ref to a hash
  2349. # that contains "tag" and/or "date" keys.
  2350. sub resolveStickyInfo
  2351. {
  2352. my($filename,$stickyTag,$stickyDate,$reset) = @_;
  2353. # Order of precedence of sticky tags:
  2354. # -A [head]
  2355. # -r /tag/
  2356. # [file entry sticky tag]
  2357. # [the tag specified in dir req_Sticky]
  2358. # [the tag specified in a parent dir req_Sticky]
  2359. # [head]
  2360. my $result;
  2361. if($reset)
  2362. {
  2363. # $result=undef;
  2364. }
  2365. elsif( defined($stickyTag) && $stickyTag ne "" )
  2366. # || ( defined($stickyDate) && $stickyDate ne "" ) # TODO
  2367. {
  2368. $result={ 'tag' => (defined($stickyTag)?$stickyTag:undef) };
  2369. # TODO: Convert -D value into the form 2011.04.10.04.46.57,
  2370. # similar to an entry line's sticky date, without the D prefix.
  2371. # It sometimes (always?) arrives as something more like
  2372. # '10 Apr 2011 04:46:57 -0000'...
  2373. # $result={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
  2374. }
  2375. elsif( defined($state->{entries}{$filename}) &&
  2376. defined($state->{entries}{$filename}{tag_or_date}) &&
  2377. $state->{entries}{$filename}{tag_or_date} ne "" )
  2378. {
  2379. my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
  2380. if($tagOrDate=~/^T([^ ]+)\s*$/)
  2381. {
  2382. $result = { 'tag' => $1 };
  2383. }
  2384. elsif($tagOrDate=~/^D([0-9.]+)\s*$/)
  2385. {
  2386. $result= { 'date' => $1 };
  2387. }
  2388. else
  2389. {
  2390. die "Unknown tag_or_date format\n";
  2391. }
  2392. }
  2393. else
  2394. {
  2395. $result=getDirStickyInfo($filename);
  2396. }
  2397. return $result;
  2398. }
  2399. # Convert a stickyInfo (ref to a hash) as returned by resolveStickyInfo into
  2400. # a form appropriate for the sticky tag field of an Entries
  2401. # line (field index 5, 0-based).
  2402. sub getStickyTagOrDate
  2403. {
  2404. my($stickyInfo)=@_;
  2405. my $result;
  2406. if(defined($stickyInfo) && defined($stickyInfo->{tag}))
  2407. {
  2408. $result="T$stickyInfo->{tag}";
  2409. }
  2410. # TODO: When/if we actually pick versions by {date} properly,
  2411. # also handle it here:
  2412. # "D$stickyInfo->{date}" (example: "D2011.04.13.20.37.07").
  2413. else
  2414. {
  2415. $result="";
  2416. }
  2417. return $result;
  2418. }
  2419. # This method cleans up the $state variable after a command that uses arguments has run
  2420. sub statecleanup
  2421. {
  2422. $state->{files} = [];
  2423. $state->{dirArgs} = {};
  2424. $state->{args} = [];
  2425. $state->{arguments} = [];
  2426. $state->{entries} = {};
  2427. $state->{dirMap} = {};
  2428. }
  2429. # Return working directory CVS revision "1.X" out
  2430. # of the working directory "entries" state, for the given filename.
  2431. # This is prefixed with a dash if the file is scheduled for removal
  2432. # when it is committed.
  2433. sub revparse
  2434. {
  2435. my $filename = shift;
  2436. return $state->{entries}{$filename}{revision};
  2437. }
  2438. # This method takes a file hash and does a CVS "file transfer". Its
  2439. # exact behaviour depends on a second, optional hash table argument:
  2440. # - If $options->{targetfile}, dump the contents to that file;
  2441. # - If $options->{print}, use M/MT to transmit the contents one line
  2442. # at a time;
  2443. # - Otherwise, transmit the size of the file, followed by the file
  2444. # contents.
  2445. sub transmitfile
  2446. {
  2447. my $filehash = shift;
  2448. my $options = shift;
  2449. if ( defined ( $filehash ) and $filehash eq "deleted" )
  2450. {
  2451. $log->warn("filehash is 'deleted'");
  2452. return;
  2453. }
  2454. die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
  2455. my $type = safe_pipe_capture('git', 'cat-file', '-t', $filehash);
  2456. chomp $type;
  2457. die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
  2458. my $size = safe_pipe_capture('git', 'cat-file', '-s', $filehash);
  2459. chomp $size;
  2460. $log->debug("transmitfile($filehash) size=$size, type=$type");
  2461. if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
  2462. {
  2463. if ( defined ( $options->{targetfile} ) )
  2464. {
  2465. my $targetfile = $options->{targetfile};
  2466. open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
  2467. print NEWFILE $_ while ( <$fh> );
  2468. close NEWFILE or die("Failed to write '$targetfile': $!");
  2469. } elsif ( defined ( $options->{print} ) && $options->{print} ) {
  2470. while ( <$fh> ) {
  2471. if( /\n\z/ ) {
  2472. print 'M ', $_;
  2473. } else {
  2474. print 'MT text ', $_, "\n";
  2475. }
  2476. }
  2477. } else {
  2478. print "$size\n";
  2479. print while ( <$fh> );
  2480. }
  2481. close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
  2482. } else {
  2483. die("Couldn't execute git-cat-file");
  2484. }
  2485. }
  2486. # This method takes a file name, and returns ( $dirpart, $filepart ) which
  2487. # refers to the directory portion and the file portion of the filename
  2488. # respectively
  2489. sub filenamesplit
  2490. {
  2491. my $filename = shift;
  2492. my $fixforlocaldir = shift;
  2493. my ( $filepart, $dirpart ) = ( $filename, "." );
  2494. ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
  2495. $dirpart .= "/";
  2496. if ( $fixforlocaldir )
  2497. {
  2498. $dirpart =~ s/^$state->{prependdir}//;
  2499. }
  2500. return ( $filepart, $dirpart );
  2501. }
  2502. # Cleanup various junk in filename (try to canonicalize it), and
  2503. # add prependdir to accommodate running CVS client from a
  2504. # subdirectory (so the output is relative to top directory of the project).
  2505. sub filecleanup
  2506. {
  2507. my $filename = shift;
  2508. return undef unless(defined($filename));
  2509. if ( $filename =~ /^\// )
  2510. {
  2511. print "E absolute filenames '$filename' not supported by server\n";
  2512. return undef;
  2513. }
  2514. if($filename eq ".")
  2515. {
  2516. $filename="";
  2517. }
  2518. $filename =~ s/^\.\///g;
  2519. $filename =~ s%/+%/%g;
  2520. $filename = $state->{prependdir} . $filename;
  2521. $filename =~ s%/$%%;
  2522. return $filename;
  2523. }
  2524. # Remove prependdir from the path, so that it is relative to the directory
  2525. # the CVS client was started from, rather than the top of the project.
  2526. # Essentially the inverse of filecleanup().
  2527. sub remove_prependdir
  2528. {
  2529. my($path) = @_;
  2530. if(defined($state->{prependdir}) && $state->{prependdir} ne "")
  2531. {
  2532. my($pre)=$state->{prependdir};
  2533. $pre=~s%/$%%;
  2534. if(!($path=~s%^\Q$pre\E/?%%))
  2535. {
  2536. $log->fatal("internal error missing prependdir");
  2537. die("internal error missing prependdir");
  2538. }
  2539. }
  2540. return $path;
  2541. }
  2542. sub validateGitDir
  2543. {
  2544. if( !defined($state->{CVSROOT}) )
  2545. {
  2546. print "error 1 CVSROOT not specified\n";
  2547. cleanupWorkTree();
  2548. exit;
  2549. }
  2550. if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
  2551. {
  2552. print "error 1 Internally inconsistent CVSROOT\n";
  2553. cleanupWorkTree();
  2554. exit;
  2555. }
  2556. }
  2557. # Setup working directory in a work tree with the requested version
  2558. # loaded in the index.
  2559. sub setupWorkTree
  2560. {
  2561. my ($ver) = @_;
  2562. validateGitDir();
  2563. if( ( defined($work->{state}) && $work->{state} != 1 ) ||
  2564. defined($work->{tmpDir}) )
  2565. {
  2566. $log->warn("Bad work tree state management");
  2567. print "error 1 Internal setup multiple work trees without cleanup\n";
  2568. cleanupWorkTree();
  2569. exit;
  2570. }
  2571. $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
  2572. if( !defined($work->{index}) )
  2573. {
  2574. (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
  2575. }
  2576. chdir $work->{workDir} or
  2577. die "Unable to chdir to $work->{workDir}\n";
  2578. $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
  2579. $ENV{GIT_WORK_TREE} = ".";
  2580. $ENV{GIT_INDEX_FILE} = $work->{index};
  2581. $work->{state} = 2;
  2582. if($ver)
  2583. {
  2584. system("git","read-tree",$ver);
  2585. unless ($? == 0)
  2586. {
  2587. $log->warn("Error running git-read-tree");
  2588. die "Error running git-read-tree $ver in $work->{workDir} $!\n";
  2589. }
  2590. }
  2591. # else # req_annotate reads tree for each file
  2592. }
  2593. # Ensure current directory is in some kind of working directory,
  2594. # with a recent version loaded in the index.
  2595. sub ensureWorkTree
  2596. {
  2597. if( defined($work->{tmpDir}) )
  2598. {
  2599. $log->warn("Bad work tree state management [ensureWorkTree()]");
  2600. print "error 1 Internal setup multiple dirs without cleanup\n";
  2601. cleanupWorkTree();
  2602. exit;
  2603. }
  2604. if( $work->{state} )
  2605. {
  2606. return;
  2607. }
  2608. validateGitDir();
  2609. if( !defined($work->{emptyDir}) )
  2610. {
  2611. $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
  2612. }
  2613. chdir $work->{emptyDir} or
  2614. die "Unable to chdir to $work->{emptyDir}\n";
  2615. my $ver = safe_pipe_capture('git', 'show-ref', '-s', "refs/heads/$state->{module}");
  2616. chomp $ver;
  2617. if ($ver !~ /^[0-9a-f]{$state->{hexsz}}$/)
  2618. {
  2619. $log->warn("Error from git show-ref -s refs/head$state->{module}");
  2620. print "error 1 cannot find the current HEAD of module";
  2621. cleanupWorkTree();
  2622. exit;
  2623. }
  2624. if( !defined($work->{index}) )
  2625. {
  2626. (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
  2627. }
  2628. $ENV{GIT_WORK_TREE} = ".";
  2629. $ENV{GIT_INDEX_FILE} = $work->{index};
  2630. $work->{state} = 1;
  2631. system("git","read-tree",$ver);
  2632. unless ($? == 0)
  2633. {
  2634. die "Error running git-read-tree $ver $!\n";
  2635. }
  2636. }
  2637. # Cleanup working directory that is not needed any longer.
  2638. sub cleanupWorkTree
  2639. {
  2640. if( ! $work->{state} )
  2641. {
  2642. return;
  2643. }
  2644. chdir "/" or die "Unable to chdir '/'\n";
  2645. if( defined($work->{workDir}) )
  2646. {
  2647. rmtree( $work->{workDir} );
  2648. undef $work->{workDir};
  2649. }
  2650. undef $work->{state};
  2651. }
  2652. # Setup a temporary directory (not a working tree), typically for
  2653. # merging dirty state as in req_update.
  2654. sub setupTmpDir
  2655. {
  2656. $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
  2657. chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
  2658. return $work->{tmpDir};
  2659. }
  2660. # Clean up a previously setupTmpDir. Restore previous work tree if
  2661. # appropriate.
  2662. sub cleanupTmpDir
  2663. {
  2664. if ( !defined($work->{tmpDir}) )
  2665. {
  2666. $log->warn("cleanup tmpdir that has not been setup");
  2667. die "Cleanup tmpDir that has not been setup\n";
  2668. }
  2669. if( defined($work->{state}) )
  2670. {
  2671. if( $work->{state} == 1 )
  2672. {
  2673. chdir $work->{emptyDir} or
  2674. die "Unable to chdir to $work->{emptyDir}\n";
  2675. }
  2676. elsif( $work->{state} == 2 )
  2677. {
  2678. chdir $work->{workDir} or
  2679. die "Unable to chdir to $work->{emptyDir}\n";
  2680. }
  2681. else
  2682. {
  2683. $log->warn("Inconsistent work dir state");
  2684. die "Inconsistent work dir state\n";
  2685. }
  2686. }
  2687. else
  2688. {
  2689. chdir "/" or die "Unable to chdir '/'\n";
  2690. }
  2691. }
  2692. # Given a path, this function returns a string containing the kopts
  2693. # that should go into that path's Entries line. For example, a binary
  2694. # file should get -kb.
  2695. sub kopts_from_path
  2696. {
  2697. my ($path, $srcType, $name) = @_;
  2698. if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
  2699. $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
  2700. {
  2701. my ($val) = check_attr( "text", $path );
  2702. if ( $val eq "unspecified" )
  2703. {
  2704. $val = check_attr( "crlf", $path );
  2705. }
  2706. if ( $val eq "unset" )
  2707. {
  2708. return "-kb"
  2709. }
  2710. elsif ( check_attr( "eol", $path ) ne "unspecified" ||
  2711. $val eq "set" || $val eq "input" )
  2712. {
  2713. return "";
  2714. }
  2715. else
  2716. {
  2717. $log->info("Unrecognized check_attr crlf $path : $val");
  2718. }
  2719. }
  2720. if ( defined ( $cfg->{gitcvs}{allbinary} ) )
  2721. {
  2722. if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
  2723. {
  2724. return "-kb";
  2725. }
  2726. elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
  2727. {
  2728. if( is_binary($srcType,$name) )
  2729. {
  2730. $log->debug("... as binary");
  2731. return "-kb";
  2732. }
  2733. else
  2734. {
  2735. $log->debug("... as text");
  2736. }
  2737. }
  2738. }
  2739. # Return "" to give no special treatment to any path
  2740. return "";
  2741. }
  2742. sub check_attr
  2743. {
  2744. my ($attr,$path) = @_;
  2745. ensureWorkTree();
  2746. if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
  2747. {
  2748. my $val = <$fh>;
  2749. close $fh;
  2750. $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
  2751. return $val;
  2752. }
  2753. else
  2754. {
  2755. return undef;
  2756. }
  2757. }
  2758. # This should have the same heuristics as convert.c:is_binary() and related.
  2759. # Note that the bare CR test is done by callers in convert.c.
  2760. sub is_binary
  2761. {
  2762. my ($srcType,$name) = @_;
  2763. $log->debug("is_binary($srcType,$name)");
  2764. # Minimize amount of interpreted code run in the inner per-character
  2765. # loop for large files, by totalling each character value and
  2766. # then analyzing the totals.
  2767. my @counts;
  2768. my $i;
  2769. for($i=0;$i<256;$i++)
  2770. {
  2771. $counts[$i]=0;
  2772. }
  2773. my $fh = open_blob_or_die($srcType,$name);
  2774. my $line;
  2775. while( defined($line=<$fh>) )
  2776. {
  2777. # Any '\0' and bare CR are considered binary.
  2778. if( $line =~ /\0|(\r[^\n])/ )
  2779. {
  2780. close($fh);
  2781. return 1;
  2782. }
  2783. # Count up each character in the line:
  2784. my $len=length($line);
  2785. for($i=0;$i<$len;$i++)
  2786. {
  2787. $counts[ord(substr($line,$i,1))]++;
  2788. }
  2789. }
  2790. close $fh;
  2791. # Don't count CR and LF as either printable/nonprintable
  2792. $counts[ord("\n")]=0;
  2793. $counts[ord("\r")]=0;
  2794. # Categorize individual character count into printable and nonprintable:
  2795. my $printable=0;
  2796. my $nonprintable=0;
  2797. for($i=0;$i<256;$i++)
  2798. {
  2799. if( $i < 32 &&
  2800. $i != ord("\b") &&
  2801. $i != ord("\t") &&
  2802. $i != 033 && # ESC
  2803. $i != 014 ) # FF
  2804. {
  2805. $nonprintable+=$counts[$i];
  2806. }
  2807. elsif( $i==127 ) # DEL
  2808. {
  2809. $nonprintable+=$counts[$i];
  2810. }
  2811. else
  2812. {
  2813. $printable+=$counts[$i];
  2814. }
  2815. }
  2816. return ($printable >> 7) < $nonprintable;
  2817. }
  2818. # Returns open file handle. Possible invocations:
  2819. # - open_blob_or_die("file",$filename);
  2820. # - open_blob_or_die("sha1",$filehash);
  2821. sub open_blob_or_die
  2822. {
  2823. my ($srcType,$name) = @_;
  2824. my ($fh);
  2825. if( $srcType eq "file" )
  2826. {
  2827. if( !open $fh,"<",$name )
  2828. {
  2829. $log->warn("Unable to open file $name: $!");
  2830. die "Unable to open file $name: $!\n";
  2831. }
  2832. }
  2833. elsif( $srcType eq "sha1" )
  2834. {
  2835. unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ )
  2836. {
  2837. $log->warn("Need filehash");
  2838. die "Need filehash\n";
  2839. }
  2840. my $type = safe_pipe_capture('git', 'cat-file', '-t', $name);
  2841. chomp $type;
  2842. unless ( defined ( $type ) and $type eq "blob" )
  2843. {
  2844. $log->warn("Invalid type '$type' for '$name'");
  2845. die ( "Invalid type '$type' (expected 'blob')" )
  2846. }
  2847. my $size = safe_pipe_capture('git', 'cat-file', '-s', $name);
  2848. chomp $size;
  2849. $log->debug("open_blob_or_die($name) size=$size, type=$type");
  2850. unless( open $fh, '-|', "git", "cat-file", "blob", $name )
  2851. {
  2852. $log->warn("Unable to open sha1 $name");
  2853. die "Unable to open sha1 $name\n";
  2854. }
  2855. }
  2856. else
  2857. {
  2858. $log->warn("Unknown type of blob source: $srcType");
  2859. die "Unknown type of blob source: $srcType\n";
  2860. }
  2861. return $fh;
  2862. }
  2863. # Generate a CVS author name from Git author information, by taking the local
  2864. # part of the email address and replacing characters not in the Portable
  2865. # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
  2866. # Login names are Unix login names, which should be restricted to this
  2867. # character set.
  2868. sub cvs_author
  2869. {
  2870. my $author_line = shift;
  2871. (my $author) = $author_line =~ /<([^@>]*)/;
  2872. $author =~ s/[^-a-zA-Z0-9_.]/_/g;
  2873. $author =~ s/^-/_/;
  2874. $author;
  2875. }
  2876. sub descramble
  2877. {
  2878. # This table is from src/scramble.c in the CVS source
  2879. my @SHIFTS = (
  2880. 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
  2881. 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
  2882. 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
  2883. 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
  2884. 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
  2885. 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
  2886. 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
  2887. 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
  2888. 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
  2889. 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
  2890. 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
  2891. 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
  2892. 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
  2893. 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
  2894. 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
  2895. 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
  2896. );
  2897. my ($str) = @_;
  2898. # This should never happen, the same password format (A) has been
  2899. # used by CVS since the beginning of time
  2900. {
  2901. my $fmt = substr($str, 0, 1);
  2902. die "invalid password format `$fmt'" unless $fmt eq 'A';
  2903. }
  2904. my @str = unpack "C*", substr($str, 1);
  2905. my $ret = join '', map { chr $SHIFTS[$_] } @str;
  2906. return $ret;
  2907. }
  2908. # Test if the (deep) values of two references to a hash are the same.
  2909. sub refHashEqual
  2910. {
  2911. my($v1,$v2) = @_;
  2912. my $out;
  2913. if(!defined($v1))
  2914. {
  2915. if(!defined($v2))
  2916. {
  2917. $out=1;
  2918. }
  2919. }
  2920. elsif( !defined($v2) ||
  2921. scalar(keys(%{$v1})) != scalar(keys(%{$v2})) )
  2922. {
  2923. # $out=undef;
  2924. }
  2925. else
  2926. {
  2927. $out=1;
  2928. my $key;
  2929. foreach $key (keys(%{$v1}))
  2930. {
  2931. if( !exists($v2->{$key}) ||
  2932. defined($v1->{$key}) ne defined($v2->{$key}) ||
  2933. ( defined($v1->{$key}) &&
  2934. $v1->{$key} ne $v2->{$key} ) )
  2935. {
  2936. $out=undef;
  2937. last;
  2938. }
  2939. }
  2940. }
  2941. return $out;
  2942. }
  2943. # an alternative to `command` that allows input to be passed as an array
  2944. # to work around shell problems with weird characters in arguments
  2945. sub safe_pipe_capture {
  2946. my @output;
  2947. if (my $pid = open my $child, '-|') {
  2948. @output = (<$child>);
  2949. close $child or die join(' ',@_).": $! $?";
  2950. } else {
  2951. exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
  2952. }
  2953. return wantarray ? @output : join('',@output);
  2954. }
  2955. package GITCVS::log;
  2956. ####
  2957. #### Copyright The Open University UK - 2006.
  2958. ####
  2959. #### Authors: Martyn Smith <martyn@catalyst.net.nz>
  2960. #### Martin Langhoff <martin@laptop.org>
  2961. ####
  2962. ####
  2963. use strict;
  2964. use warnings;
  2965. =head1 NAME
  2966. GITCVS::log
  2967. =head1 DESCRIPTION
  2968. This module provides very crude logging with a similar interface to
  2969. Log::Log4perl
  2970. =head1 METHODS
  2971. =cut
  2972. =head2 new
  2973. Creates a new log object, optionally you can specify a filename here to
  2974. indicate the file to log to. If no log file is specified, you can specify one
  2975. later with method setfile, or indicate you no longer want logging with method
  2976. nofile.
  2977. Until one of these methods is called, all log calls will buffer messages ready
  2978. to write out.
  2979. =cut
  2980. sub new
  2981. {
  2982. my $class = shift;
  2983. my $filename = shift;
  2984. my $self = {};
  2985. bless $self, $class;
  2986. if ( defined ( $filename ) )
  2987. {
  2988. open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
  2989. }
  2990. return $self;
  2991. }
  2992. =head2 setfile
  2993. This methods takes a filename, and attempts to open that file as the log file.
  2994. If successful, all buffered data is written out to the file, and any further
  2995. logging is written directly to the file.
  2996. =cut
  2997. sub setfile
  2998. {
  2999. my $self = shift;
  3000. my $filename = shift;
  3001. if ( defined ( $filename ) )
  3002. {
  3003. open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
  3004. }
  3005. return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
  3006. while ( my $line = shift @{$self->{buffer}} )
  3007. {
  3008. print {$self->{fh}} $line;
  3009. }
  3010. }
  3011. =head2 nofile
  3012. This method indicates no logging is going to be used. It flushes any entries in
  3013. the internal buffer, and sets a flag to ensure no further data is put there.
  3014. =cut
  3015. sub nofile
  3016. {
  3017. my $self = shift;
  3018. $self->{nolog} = 1;
  3019. return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
  3020. $self->{buffer} = [];
  3021. }
  3022. =head2 _logopen
  3023. Internal method. Returns true if the log file is open, false otherwise.
  3024. =cut
  3025. sub _logopen
  3026. {
  3027. my $self = shift;
  3028. return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
  3029. return 0;
  3030. }
  3031. =head2 debug info warn fatal
  3032. These four methods are wrappers to _log. They provide the actual interface for
  3033. logging data.
  3034. =cut
  3035. sub debug { my $self = shift; $self->_log("debug", @_); }
  3036. sub info { my $self = shift; $self->_log("info" , @_); }
  3037. sub warn { my $self = shift; $self->_log("warn" , @_); }
  3038. sub fatal { my $self = shift; $self->_log("fatal", @_); }
  3039. =head2 _log
  3040. This is an internal method called by the logging functions. It generates a
  3041. timestamp and pushes the logged line either to file, or internal buffer.
  3042. =cut
  3043. sub _log
  3044. {
  3045. my $self = shift;
  3046. my $level = shift;
  3047. return if ( $self->{nolog} );
  3048. my @time = localtime;
  3049. my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
  3050. $time[5] + 1900,
  3051. $time[4] + 1,
  3052. $time[3],
  3053. $time[2],
  3054. $time[1],
  3055. $time[0],
  3056. uc $level,
  3057. );
  3058. if ( $self->_logopen )
  3059. {
  3060. print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
  3061. } else {
  3062. push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
  3063. }
  3064. }
  3065. =head2 DESTROY
  3066. This method simply closes the file handle if one is open
  3067. =cut
  3068. sub DESTROY
  3069. {
  3070. my $self = shift;
  3071. if ( $self->_logopen )
  3072. {
  3073. close $self->{fh};
  3074. }
  3075. }
  3076. package GITCVS::updater;
  3077. ####
  3078. #### Copyright The Open University UK - 2006.
  3079. ####
  3080. #### Authors: Martyn Smith <martyn@catalyst.net.nz>
  3081. #### Martin Langhoff <martin@laptop.org>
  3082. ####
  3083. ####
  3084. use strict;
  3085. use warnings;
  3086. use DBI;
  3087. =head1 METHODS
  3088. =cut
  3089. =head2 new
  3090. =cut
  3091. sub new
  3092. {
  3093. my $class = shift;
  3094. my $config = shift;
  3095. my $module = shift;
  3096. my $log = shift;
  3097. die "Need to specify a git repository" unless ( defined($config) and -d $config );
  3098. die "Need to specify a module" unless ( defined($module) );
  3099. $class = ref($class) || $class;
  3100. my $self = {};
  3101. bless $self, $class;
  3102. $self->{valid_tables} = {'revision' => 1,
  3103. 'revision_ix1' => 1,
  3104. 'revision_ix2' => 1,
  3105. 'head' => 1,
  3106. 'head_ix1' => 1,
  3107. 'properties' => 1,
  3108. 'commitmsgs' => 1};
  3109. $self->{module} = $module;
  3110. $self->{git_path} = $config . "/";
  3111. $self->{log} = $log;
  3112. die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
  3113. # Stores full sha1's for various branch/tag names, abbreviations, etc:
  3114. $self->{commitRefCache} = {};
  3115. $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
  3116. $cfg->{gitcvs}{dbdriver} || "SQLite";
  3117. $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
  3118. $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
  3119. $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
  3120. $cfg->{gitcvs}{dbuser} || "";
  3121. $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
  3122. $cfg->{gitcvs}{dbpass} || "";
  3123. $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
  3124. $cfg->{gitcvs}{dbtablenameprefix} || "";
  3125. my %mapping = ( m => $module,
  3126. a => $state->{method},
  3127. u => getlogin || getpwuid($<) || $<,
  3128. G => $self->{git_path},
  3129. g => mangle_dirname($self->{git_path}),
  3130. );
  3131. $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
  3132. $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
  3133. $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
  3134. $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
  3135. die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
  3136. die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
  3137. $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
  3138. $self->{dbuser},
  3139. $self->{dbpass});
  3140. die "Error connecting to database\n" unless defined $self->{dbh};
  3141. $self->{tables} = {};
  3142. foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
  3143. {
  3144. $self->{tables}{$table} = 1;
  3145. }
  3146. # Construct the revision table if required
  3147. # The revision table stores an entry for each file, each time that file
  3148. # changes.
  3149. # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
  3150. # This is not sufficient to support "-r {commithash}" for any
  3151. # files except files that were modified by that commit (also,
  3152. # some places in the code ignore/effectively strip out -r in
  3153. # some cases, before it gets passed to getmeta()).
  3154. # The "filehash" field typically has a git blob hash, but can also
  3155. # be set to "dead" to indicate that the given version of the file
  3156. # should not exist in the sandbox.
  3157. unless ( $self->{tables}{$self->tablename("revision")} )
  3158. {
  3159. my $tablename = $self->tablename("revision");
  3160. my $ix1name = $self->tablename("revision_ix1");
  3161. my $ix2name = $self->tablename("revision_ix2");
  3162. $self->{dbh}->do("
  3163. CREATE TABLE $tablename (
  3164. name TEXT NOT NULL,
  3165. revision INTEGER NOT NULL,
  3166. filehash TEXT NOT NULL,
  3167. commithash TEXT NOT NULL,
  3168. author TEXT NOT NULL,
  3169. modified TEXT NOT NULL,
  3170. mode TEXT NOT NULL
  3171. )
  3172. ");
  3173. $self->{dbh}->do("
  3174. CREATE INDEX $ix1name
  3175. ON $tablename (name,revision)
  3176. ");
  3177. $self->{dbh}->do("
  3178. CREATE INDEX $ix2name
  3179. ON $tablename (name,commithash)
  3180. ");
  3181. }
  3182. # Construct the head table if required
  3183. # The head table (along with the "last_commit" entry in the property
  3184. # table) is the persisted working state of the "sub update" subroutine.
  3185. # All of it's data is read entirely first, and completely recreated
  3186. # last, every time "sub update" runs.
  3187. # This is also used by "sub getmeta" when it is asked for the latest
  3188. # version of a file (as opposed to some specific version).
  3189. # Another way of thinking about it is as a single slice out of
  3190. # "revisions", giving just the most recent revision information for
  3191. # each file.
  3192. unless ( $self->{tables}{$self->tablename("head")} )
  3193. {
  3194. my $tablename = $self->tablename("head");
  3195. my $ix1name = $self->tablename("head_ix1");
  3196. $self->{dbh}->do("
  3197. CREATE TABLE $tablename (
  3198. name TEXT NOT NULL,
  3199. revision INTEGER NOT NULL,
  3200. filehash TEXT NOT NULL,
  3201. commithash TEXT NOT NULL,
  3202. author TEXT NOT NULL,
  3203. modified TEXT NOT NULL,
  3204. mode TEXT NOT NULL
  3205. )
  3206. ");
  3207. $self->{dbh}->do("
  3208. CREATE INDEX $ix1name
  3209. ON $tablename (name)
  3210. ");
  3211. }
  3212. # Construct the properties table if required
  3213. # - "last_commit" - Used by "sub update".
  3214. unless ( $self->{tables}{$self->tablename("properties")} )
  3215. {
  3216. my $tablename = $self->tablename("properties");
  3217. $self->{dbh}->do("
  3218. CREATE TABLE $tablename (
  3219. key TEXT NOT NULL PRIMARY KEY,
  3220. value TEXT
  3221. )
  3222. ");
  3223. }
  3224. # Construct the commitmsgs table if required
  3225. # The commitmsgs table is only used for merge commits, since
  3226. # "sub update" will only keep one branch of parents. Shortlogs
  3227. # for ignored commits (i.e. not on the chosen branch) will be used
  3228. # to construct a replacement "collapsed" merge commit message,
  3229. # which will be stored in this table. See also "sub commitmessage".
  3230. unless ( $self->{tables}{$self->tablename("commitmsgs")} )
  3231. {
  3232. my $tablename = $self->tablename("commitmsgs");
  3233. $self->{dbh}->do("
  3234. CREATE TABLE $tablename (
  3235. key TEXT NOT NULL PRIMARY KEY,
  3236. value TEXT
  3237. )
  3238. ");
  3239. }
  3240. return $self;
  3241. }
  3242. =head2 tablename
  3243. =cut
  3244. sub tablename
  3245. {
  3246. my $self = shift;
  3247. my $name = shift;
  3248. if (exists $self->{valid_tables}{$name}) {
  3249. return $self->{dbtablenameprefix} . $name;
  3250. } else {
  3251. return undef;
  3252. }
  3253. }
  3254. =head2 update
  3255. Bring the database up to date with the latest changes from
  3256. the git repository.
  3257. Internal working state is read out of the "head" table and the
  3258. "last_commit" property, then it updates "revisions" based on that, and
  3259. finally it writes the new internal state back to the "head" table
  3260. so it can be used as a starting point the next time update is called.
  3261. =cut
  3262. sub update
  3263. {
  3264. my $self = shift;
  3265. # first lets get the commit list
  3266. $ENV{GIT_DIR} = $self->{git_path};
  3267. my $commitsha1 = ::safe_pipe_capture('git', 'rev-parse', $self->{module});
  3268. chomp $commitsha1;
  3269. my $commitinfo = ::safe_pipe_capture('git', 'cat-file', 'commit', $self->{module});
  3270. unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{$state->{hexsz}}/ )
  3271. {
  3272. die("Invalid module '$self->{module}'");
  3273. }
  3274. my $git_log;
  3275. my $lastcommit = $self->_get_prop("last_commit");
  3276. if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
  3277. # invalidate the gethead cache
  3278. $self->clearCommitRefCaches();
  3279. return 1;
  3280. }
  3281. # Start exclusive lock here...
  3282. $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
  3283. # TODO: log processing is memory bound
  3284. # if we can parse into a 2nd file that is in reverse order
  3285. # we can probably do something really efficient
  3286. my @git_log_params = ('--pretty', '--parents', '--topo-order');
  3287. if (defined $lastcommit) {
  3288. push @git_log_params, "$lastcommit..$self->{module}";
  3289. } else {
  3290. push @git_log_params, $self->{module};
  3291. }
  3292. # git-rev-list is the backend / plumbing version of git-log
  3293. open(my $gitLogPipe, '-|', 'git', 'rev-list', @git_log_params)
  3294. or die "Cannot call git-rev-list: $!";
  3295. my @commits=readCommits($gitLogPipe);
  3296. close $gitLogPipe;
  3297. # Now all the commits are in the @commits bucket
  3298. # ordered by time DESC. for each commit that needs processing,
  3299. # determine whether it's following the last head we've seen or if
  3300. # it's on its own branch, grab a file list, and add whatever's changed
  3301. # NOTE: $lastcommit refers to the last commit from previous run
  3302. # $lastpicked is the last commit we picked in this run
  3303. my $lastpicked;
  3304. my $head = {};
  3305. if (defined $lastcommit) {
  3306. $lastpicked = $lastcommit;
  3307. }
  3308. my $committotal = scalar(@commits);
  3309. my $commitcount = 0;
  3310. # Load the head table into $head (for cached lookups during the update process)
  3311. foreach my $file ( @{$self->gethead(1)} )
  3312. {
  3313. $head->{$file->{name}} = $file;
  3314. }
  3315. foreach my $commit ( @commits )
  3316. {
  3317. $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
  3318. if (defined $lastpicked)
  3319. {
  3320. if (!in_array($lastpicked, @{$commit->{parents}}))
  3321. {
  3322. # skip, we'll see this delta
  3323. # as part of a merge later
  3324. # warn "skipping off-track $commit->{hash}\n";
  3325. next;
  3326. } elsif (@{$commit->{parents}} > 1) {
  3327. # it is a merge commit, for each parent that is
  3328. # not $lastpicked (not given a CVS revision number),
  3329. # see if we can get a log
  3330. # from the merge-base to that parent to put it
  3331. # in the message as a merge summary.
  3332. my @parents = @{$commit->{parents}};
  3333. foreach my $parent (@parents) {
  3334. if ($parent eq $lastpicked) {
  3335. next;
  3336. }
  3337. # git-merge-base can potentially (but rarely) throw
  3338. # several candidate merge bases. let's assume
  3339. # that the first one is the best one.
  3340. my $base = eval {
  3341. ::safe_pipe_capture('git', 'merge-base',
  3342. $lastpicked, $parent);
  3343. };
  3344. # The two branches may not be related at all,
  3345. # in which case merge base simply fails to find
  3346. # any, but that's Ok.
  3347. next if ($@);
  3348. chomp $base;
  3349. if ($base) {
  3350. my @merged;
  3351. # print "want to log between $base $parent \n";
  3352. open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
  3353. or die "Cannot call git-log: $!";
  3354. my $mergedhash;
  3355. while (<GITLOG>) {
  3356. chomp;
  3357. if (!defined $mergedhash) {
  3358. if (m/^commit\s+(.+)$/) {
  3359. $mergedhash = $1;
  3360. } else {
  3361. next;
  3362. }
  3363. } else {
  3364. # grab the first line that looks non-rfc822
  3365. # aka has content after leading space
  3366. if (m/^\s+(\S.*)$/) {
  3367. my $title = $1;
  3368. $title = substr($title,0,100); # truncate
  3369. unshift @merged, "$mergedhash $title";
  3370. undef $mergedhash;
  3371. }
  3372. }
  3373. }
  3374. close GITLOG;
  3375. if (@merged) {
  3376. $commit->{mergemsg} = $commit->{message};
  3377. $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
  3378. foreach my $summary (@merged) {
  3379. $commit->{mergemsg} .= "\t$summary\n";
  3380. }
  3381. $commit->{mergemsg} .= "\n\n";
  3382. # print "Message for $commit->{hash} \n$commit->{mergemsg}";
  3383. }
  3384. }
  3385. }
  3386. }
  3387. }
  3388. # convert the date to CVS-happy format
  3389. my $cvsDate = convertToCvsDate($commit->{date});
  3390. if ( defined ( $lastpicked ) )
  3391. {
  3392. my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
  3393. local ($/) = "\0";
  3394. while ( <FILELIST> )
  3395. {
  3396. chomp;
  3397. unless ( /^:\d{6}\s+([0-7]{6})\s+[a-f0-9]{$state->{hexsz}}\s+([a-f0-9]{$state->{hexsz}})\s+(\w)$/o )
  3398. {
  3399. die("Couldn't process git-diff-tree line : $_");
  3400. }
  3401. my ($mode, $hash, $change) = ($1, $2, $3);
  3402. my $name = <FILELIST>;
  3403. chomp($name);
  3404. # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
  3405. my $dbMode = convertToDbMode($mode);
  3406. if ( $change eq "D" )
  3407. {
  3408. #$log->debug("DELETE $name");
  3409. $head->{$name} = {
  3410. name => $name,
  3411. revision => $head->{$name}{revision} + 1,
  3412. filehash => "deleted",
  3413. commithash => $commit->{hash},
  3414. modified => $cvsDate,
  3415. author => $commit->{author},
  3416. mode => $dbMode,
  3417. };
  3418. $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
  3419. }
  3420. elsif ( $change eq "M" || $change eq "T" )
  3421. {
  3422. #$log->debug("MODIFIED $name");
  3423. $head->{$name} = {
  3424. name => $name,
  3425. revision => $head->{$name}{revision} + 1,
  3426. filehash => $hash,
  3427. commithash => $commit->{hash},
  3428. modified => $cvsDate,
  3429. author => $commit->{author},
  3430. mode => $dbMode,
  3431. };
  3432. $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
  3433. }
  3434. elsif ( $change eq "A" )
  3435. {
  3436. #$log->debug("ADDED $name");
  3437. $head->{$name} = {
  3438. name => $name,
  3439. revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
  3440. filehash => $hash,
  3441. commithash => $commit->{hash},
  3442. modified => $cvsDate,
  3443. author => $commit->{author},
  3444. mode => $dbMode,
  3445. };
  3446. $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
  3447. }
  3448. else
  3449. {
  3450. $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
  3451. die;
  3452. }
  3453. }
  3454. close FILELIST;
  3455. } else {
  3456. # this is used to detect files removed from the repo
  3457. my $seen_files = {};
  3458. my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
  3459. local $/ = "\0";
  3460. while ( <FILELIST> )
  3461. {
  3462. chomp;
  3463. unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
  3464. {
  3465. die("Couldn't process git-ls-tree line : $_");
  3466. }
  3467. my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
  3468. $seen_files->{$git_filename} = 1;
  3469. my ( $oldhash, $oldrevision, $oldmode ) = (
  3470. $head->{$git_filename}{filehash},
  3471. $head->{$git_filename}{revision},
  3472. $head->{$git_filename}{mode}
  3473. );
  3474. my $dbMode = convertToDbMode($mode);
  3475. # unless the file exists with the same hash, we need to update it ...
  3476. unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $dbMode )
  3477. {
  3478. my $newrevision = ( $oldrevision or 0 ) + 1;
  3479. $head->{$git_filename} = {
  3480. name => $git_filename,
  3481. revision => $newrevision,
  3482. filehash => $git_hash,
  3483. commithash => $commit->{hash},
  3484. modified => $cvsDate,
  3485. author => $commit->{author},
  3486. mode => $dbMode,
  3487. };
  3488. $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
  3489. }
  3490. }
  3491. close FILELIST;
  3492. # Detect deleted files
  3493. foreach my $file ( sort keys %$head )
  3494. {
  3495. unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
  3496. {
  3497. $head->{$file}{revision}++;
  3498. $head->{$file}{filehash} = "deleted";
  3499. $head->{$file}{commithash} = $commit->{hash};
  3500. $head->{$file}{modified} = $cvsDate;
  3501. $head->{$file}{author} = $commit->{author};
  3502. $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $cvsDate, $commit->{author}, $head->{$file}{mode});
  3503. }
  3504. }
  3505. # END : "Detect deleted files"
  3506. }
  3507. if (exists $commit->{mergemsg})
  3508. {
  3509. $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
  3510. }
  3511. $lastpicked = $commit->{hash};
  3512. $self->_set_prop("last_commit", $commit->{hash});
  3513. }
  3514. $self->delete_head();
  3515. foreach my $file ( sort keys %$head )
  3516. {
  3517. $self->insert_head(
  3518. $file,
  3519. $head->{$file}{revision},
  3520. $head->{$file}{filehash},
  3521. $head->{$file}{commithash},
  3522. $head->{$file}{modified},
  3523. $head->{$file}{author},
  3524. $head->{$file}{mode},
  3525. );
  3526. }
  3527. # invalidate the gethead cache
  3528. $self->clearCommitRefCaches();
  3529. # Ending exclusive lock here
  3530. $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
  3531. }
  3532. sub readCommits
  3533. {
  3534. my $pipeHandle = shift;
  3535. my @commits;
  3536. my %commit = ();
  3537. while ( <$pipeHandle> )
  3538. {
  3539. chomp;
  3540. if (m/^commit\s+(.*)$/) {
  3541. # on ^commit lines put the just seen commit in the stack
  3542. # and prime things for the next one
  3543. if (keys %commit) {
  3544. my %copy = %commit;
  3545. unshift @commits, \%copy;
  3546. %commit = ();
  3547. }
  3548. my @parents = split(m/\s+/, $1);
  3549. $commit{hash} = shift @parents;
  3550. $commit{parents} = \@parents;
  3551. } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
  3552. # on rfc822-like lines seen before we see any message,
  3553. # lowercase the entry and put it in the hash as key-value
  3554. $commit{lc($1)} = $2;
  3555. } else {
  3556. # message lines - skip initial empty line
  3557. # and trim whitespace
  3558. if (!exists($commit{message}) && m/^\s*$/) {
  3559. # define it to mark the end of headers
  3560. $commit{message} = '';
  3561. next;
  3562. }
  3563. s/^\s+//; s/\s+$//; # trim ws
  3564. $commit{message} .= $_ . "\n";
  3565. }
  3566. }
  3567. unshift @commits, \%commit if ( keys %commit );
  3568. return @commits;
  3569. }
  3570. sub convertToCvsDate
  3571. {
  3572. my $date = shift;
  3573. # Convert from: "git rev-list --pretty" formatted date
  3574. # Convert to: "the format specified by RFC822 as modified by RFC1123."
  3575. # Example: 26 May 1997 13:01:40 -0400
  3576. if( $date =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ )
  3577. {
  3578. $date = "$2 $1 $4 $3 $5";
  3579. }
  3580. return $date;
  3581. }
  3582. sub convertToDbMode
  3583. {
  3584. my $mode = shift;
  3585. # NOTE: The CVS protocol uses a string similar "u=rw,g=rw,o=rw",
  3586. # but the database "mode" column historically (and currently)
  3587. # only stores the "rw" (for user) part of the string.
  3588. # FUTURE: It might make more sense to persist the raw
  3589. # octal mode (or perhaps the final full CVS form) instead of
  3590. # this half-converted form, but it isn't currently worth the
  3591. # backwards compatibility headaches.
  3592. $mode=~/^\d{3}(\d)\d\d$/;
  3593. my $userBits=$1;
  3594. my $dbMode = "";
  3595. $dbMode .= "r" if ( $userBits & 4 );
  3596. $dbMode .= "w" if ( $userBits & 2 );
  3597. $dbMode .= "x" if ( $userBits & 1 );
  3598. $dbMode = "rw" if ( $dbMode eq "" );
  3599. return $dbMode;
  3600. }
  3601. sub insert_rev
  3602. {
  3603. my $self = shift;
  3604. my $name = shift;
  3605. my $revision = shift;
  3606. my $filehash = shift;
  3607. my $commithash = shift;
  3608. my $modified = shift;
  3609. my $author = shift;
  3610. my $mode = shift;
  3611. my $tablename = $self->tablename("revision");
  3612. my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
  3613. $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
  3614. }
  3615. sub insert_mergelog
  3616. {
  3617. my $self = shift;
  3618. my $key = shift;
  3619. my $value = shift;
  3620. my $tablename = $self->tablename("commitmsgs");
  3621. my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
  3622. $insert_mergelog->execute($key, $value);
  3623. }
  3624. sub delete_head
  3625. {
  3626. my $self = shift;
  3627. my $tablename = $self->tablename("head");
  3628. my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
  3629. $delete_head->execute();
  3630. }
  3631. sub insert_head
  3632. {
  3633. my $self = shift;
  3634. my $name = shift;
  3635. my $revision = shift;
  3636. my $filehash = shift;
  3637. my $commithash = shift;
  3638. my $modified = shift;
  3639. my $author = shift;
  3640. my $mode = shift;
  3641. my $tablename = $self->tablename("head");
  3642. my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
  3643. $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
  3644. }
  3645. sub _get_prop
  3646. {
  3647. my $self = shift;
  3648. my $key = shift;
  3649. my $tablename = $self->tablename("properties");
  3650. my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
  3651. $db_query->execute($key);
  3652. my ( $value ) = $db_query->fetchrow_array;
  3653. return $value;
  3654. }
  3655. sub _set_prop
  3656. {
  3657. my $self = shift;
  3658. my $key = shift;
  3659. my $value = shift;
  3660. my $tablename = $self->tablename("properties");
  3661. my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
  3662. $db_query->execute($value, $key);
  3663. unless ( $db_query->rows )
  3664. {
  3665. $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
  3666. $db_query->execute($key, $value);
  3667. }
  3668. return $value;
  3669. }
  3670. =head2 gethead
  3671. =cut
  3672. sub gethead
  3673. {
  3674. my $self = shift;
  3675. my $intRev = shift;
  3676. my $tablename = $self->tablename("head");
  3677. return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
  3678. my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
  3679. $db_query->execute();
  3680. my $tree = [];
  3681. while ( my $file = $db_query->fetchrow_hashref )
  3682. {
  3683. if(!$intRev)
  3684. {
  3685. $file->{revision} = "1.$file->{revision}"
  3686. }
  3687. push @$tree, $file;
  3688. }
  3689. $self->{gethead_cache} = $tree;
  3690. return $tree;
  3691. }
  3692. =head2 getAnyHead
  3693. Returns a reference to an array of getmeta structures, one
  3694. per file in the specified tree hash.
  3695. =cut
  3696. sub getAnyHead
  3697. {
  3698. my ($self,$hash) = @_;
  3699. if(!defined($hash))
  3700. {
  3701. return $self->gethead();
  3702. }
  3703. my @files;
  3704. {
  3705. open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
  3706. or die("Cannot call git-ls-tree : $!");
  3707. local $/ = "\0";
  3708. @files=<$filePipe>;
  3709. close $filePipe;
  3710. }
  3711. my $tree=[];
  3712. my($line);
  3713. foreach $line (@files)
  3714. {
  3715. $line=~s/\0$//;
  3716. unless ( $line=~/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
  3717. {
  3718. die("Couldn't process git-ls-tree line : $_");
  3719. }
  3720. my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
  3721. push @$tree, $self->getMetaFromCommithash($git_filename,$hash);
  3722. }
  3723. return $tree;
  3724. }
  3725. =head2 getRevisionDirMap
  3726. A "revision dir map" contains all the plain-file filenames associated
  3727. with a particular revision (tree-ish), organized by directory:
  3728. $type = $out->{$dir}{$fullName}
  3729. The type of each is "F" (for ordinary file) or "D" (for directory,
  3730. for which the map $out->{$fullName} will also exist).
  3731. =cut
  3732. sub getRevisionDirMap
  3733. {
  3734. my ($self,$ver)=@_;
  3735. if(!defined($self->{revisionDirMapCache}))
  3736. {
  3737. $self->{revisionDirMapCache}={};
  3738. }
  3739. # Get file list (previously cached results are dependent on HEAD,
  3740. # but are early in each case):
  3741. my $cacheKey;
  3742. my (@fileList);
  3743. if( !defined($ver) || $ver eq "" )
  3744. {
  3745. $cacheKey="";
  3746. if( defined($self->{revisionDirMapCache}{$cacheKey}) )
  3747. {
  3748. return $self->{revisionDirMapCache}{$cacheKey};
  3749. }
  3750. my @head = @{$self->gethead()};
  3751. foreach my $file ( @head )
  3752. {
  3753. next if ( $file->{filehash} eq "deleted" );
  3754. push @fileList,$file->{name};
  3755. }
  3756. }
  3757. else
  3758. {
  3759. my ($hash)=$self->lookupCommitRef($ver);
  3760. if( !defined($hash) )
  3761. {
  3762. return undef;
  3763. }
  3764. $cacheKey=$hash;
  3765. if( defined($self->{revisionDirMapCache}{$cacheKey}) )
  3766. {
  3767. return $self->{revisionDirMapCache}{$cacheKey};
  3768. }
  3769. open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
  3770. or die("Cannot call git-ls-tree : $!");
  3771. local $/ = "\0";
  3772. while ( <$filePipe> )
  3773. {
  3774. chomp;
  3775. unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
  3776. {
  3777. die("Couldn't process git-ls-tree line : $_");
  3778. }
  3779. my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
  3780. push @fileList, $git_filename;
  3781. }
  3782. close $filePipe;
  3783. }
  3784. # Convert to normalized form:
  3785. my %revMap;
  3786. my $file;
  3787. foreach $file (@fileList)
  3788. {
  3789. my($dir) = ($file=~m%^(?:(.*)/)?([^/]*)$%);
  3790. $dir='' if(!defined($dir));
  3791. # parent directories:
  3792. # ... create empty dir maps for parent dirs:
  3793. my($td)=$dir;
  3794. while(!defined($revMap{$td}))
  3795. {
  3796. $revMap{$td}={};
  3797. my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
  3798. $tp='' if(!defined($tp));
  3799. $td=$tp;
  3800. }
  3801. # ... add children to parent maps (now that they exist):
  3802. $td=$dir;
  3803. while($td ne "")
  3804. {
  3805. my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
  3806. $tp='' if(!defined($tp));
  3807. if(defined($revMap{$tp}{$td}))
  3808. {
  3809. if($revMap{$tp}{$td} ne 'D')
  3810. {
  3811. die "Weird file/directory inconsistency in $cacheKey";
  3812. }
  3813. last; # loop exit
  3814. }
  3815. $revMap{$tp}{$td}='D';
  3816. $td=$tp;
  3817. }
  3818. # file
  3819. $revMap{$dir}{$file}='F';
  3820. }
  3821. # Save in cache:
  3822. $self->{revisionDirMapCache}{$cacheKey}=\%revMap;
  3823. return $self->{revisionDirMapCache}{$cacheKey};
  3824. }
  3825. =head2 getlog
  3826. See also gethistorydense().
  3827. =cut
  3828. sub getlog
  3829. {
  3830. my $self = shift;
  3831. my $filename = shift;
  3832. my $revFilter = shift;
  3833. my $tablename = $self->tablename("revision");
  3834. # Filters:
  3835. # TODO: date, state, or by specific logins filters?
  3836. # TODO: Handle comma-separated list of revFilter items, each item
  3837. # can be a range [only case currently handled] or individual
  3838. # rev or branch or "branch.".
  3839. # TODO: Adjust $db_query WHERE clause based on revFilter, instead of
  3840. # manually filtering the results of the query?
  3841. my ( $minrev, $maxrev );
  3842. if( defined($revFilter) and
  3843. $state->{opt}{r} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ )
  3844. {
  3845. my $control = $3;
  3846. $minrev = $2;
  3847. $maxrev = $5;
  3848. $minrev++ if ( defined($minrev) and $control eq "::" );
  3849. }
  3850. my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
  3851. $db_query->execute($filename);
  3852. my $totalRevs=0;
  3853. my $tree = [];
  3854. while ( my $file = $db_query->fetchrow_hashref )
  3855. {
  3856. $totalRevs++;
  3857. if( defined($minrev) and $file->{revision} < $minrev )
  3858. {
  3859. next;
  3860. }
  3861. if( defined($maxrev) and $file->{revision} > $maxrev )
  3862. {
  3863. next;
  3864. }
  3865. $file->{revision} = "1." . $file->{revision};
  3866. push @$tree, $file;
  3867. }
  3868. return ($tree,$totalRevs);
  3869. }
  3870. =head2 getmeta
  3871. This function takes a filename (with path) argument and returns a hashref of
  3872. metadata for that file.
  3873. There are several ways $revision can be specified:
  3874. - A reference to hash that contains a "tag" that is the
  3875. actual revision (one of the below). TODO: Also allow it to
  3876. specify a "date" in the hash.
  3877. - undef, to refer to the latest version on the main branch.
  3878. - Full CVS client revision number (mapped to integer in DB, without the
  3879. "1." prefix),
  3880. - Complex CVS-compatible "special" revision number for
  3881. non-linear history (see comment below)
  3882. - git commit sha1 hash
  3883. - branch or tag name
  3884. =cut
  3885. sub getmeta
  3886. {
  3887. my $self = shift;
  3888. my $filename = shift;
  3889. my $revision = shift;
  3890. my $tablename_rev = $self->tablename("revision");
  3891. my $tablename_head = $self->tablename("head");
  3892. if ( ref($revision) eq "HASH" )
  3893. {
  3894. $revision = $revision->{tag};
  3895. }
  3896. # Overview of CVS revision numbers:
  3897. #
  3898. # General CVS numbering scheme:
  3899. # - Basic mainline branch numbers: "1.1", "1.2", "1.3", etc.
  3900. # - Result of "cvs checkin -r" (possible, but not really
  3901. # recommended): "2.1", "2.2", etc
  3902. # - Branch tag: "1.2.0.n", where "1.2" is revision it was branched
  3903. # from, "0" is a magic placeholder that identifies it as a
  3904. # branch tag instead of a version tag, and n is 2 times the
  3905. # branch number off of "1.2", starting with "2".
  3906. # - Version on a branch: "1.2.n.x", where "1.2" is branch-from, "n"
  3907. # is branch number off of "1.2" (like n above), and "x" is
  3908. # the version number on the branch.
  3909. # - Branches can branch off of branches: "1.3.2.7.4.1" (even number
  3910. # of components).
  3911. # - Odd "n"s are used by "vendor branches" that result
  3912. # from "cvs import". Vendor branches have additional
  3913. # strangeness in the sense that the main rcs "head" of the main
  3914. # branch will (temporarily until first normal commit) point
  3915. # to the version on the vendor branch, rather than the actual
  3916. # main branch. (FUTURE: This may provide an opportunity
  3917. # to use "strange" revision numbers for fast-forward-merged
  3918. # branch tip when CVS client is asking for the main branch.)
  3919. #
  3920. # git-cvsserver CVS-compatible special numbering schemes:
  3921. # - Currently git-cvsserver only tries to be identical to CVS for
  3922. # simple "1.x" numbers on the "main" branch (as identified
  3923. # by the module name that was originally cvs checkout'ed).
  3924. # - The database only stores the "x" part, for historical reasons.
  3925. # But most of the rest of the cvsserver preserves
  3926. # and thinks using the full revision number.
  3927. # - To handle non-linear history, it uses a version of the form
  3928. # "2.1.1.2000.b.b.b."..., where the 2.1.1.2000 is to help uniquely
  3929. # identify this as a special revision number, and there are
  3930. # 20 b's that together encode the sha1 git commit from which
  3931. # this version of this file originated. Each b is
  3932. # the numerical value of the corresponding byte plus
  3933. # 100.
  3934. # - "plus 100" avoids "0"s, and also reduces the
  3935. # likelihood of a collision in the case that someone someday
  3936. # writes an import tool that tries to preserve original
  3937. # CVS revision numbers, and the original CVS data had done
  3938. # lots of branches off of branches and other strangeness to
  3939. # end up with a real version number that just happens to look
  3940. # like this special revision number form. Also, if needed
  3941. # there are several ways to extend/identify alternative encodings
  3942. # within the "2.1.1.2000" part if necessary.
  3943. # - Unlike real CVS revisions, you can't really reconstruct what
  3944. # relation a revision of this form has to other revisions.
  3945. # - FUTURE: TODO: Rework database somehow to make up and remember
  3946. # fully-CVS-compatible branches and branch version numbers.
  3947. my $meta;
  3948. if ( defined($revision) )
  3949. {
  3950. if ( $revision =~ /^1\.(\d+)$/ )
  3951. {
  3952. my ($intRev) = $1;
  3953. my $db_query;
  3954. $db_query = $self->{dbh}->prepare_cached(
  3955. "SELECT * FROM $tablename_rev WHERE name=? AND revision=?",
  3956. {},1);
  3957. $db_query->execute($filename, $intRev);
  3958. $meta = $db_query->fetchrow_hashref;
  3959. }
  3960. elsif ( $revision =~ /^2\.1\.1\.2000(\.[1-3][0-9][0-9]){$state->{rawsz}}$/ )
  3961. {
  3962. my ($commitHash)=($revision=~/^2\.1\.1\.2000(.*)$/);
  3963. $commitHash=~s/\.([0-9]+)/sprintf("%02x",$1-100)/eg;
  3964. if($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/)
  3965. {
  3966. return $self->getMetaFromCommithash($filename,$commitHash);
  3967. }
  3968. # error recovery: fall back on head version below
  3969. print "E Failed to find $filename version=$revision or commit=$commitHash\n";
  3970. $log->warning("failed get $revision with commithash=$commitHash");
  3971. undef $revision;
  3972. }
  3973. elsif ( $revision =~ /^[0-9a-f]{$state->{hexsz}}$/ )
  3974. {
  3975. # Try DB first. This is mostly only useful for req_annotate(),
  3976. # which only calls this for stuff that should already be in
  3977. # the DB. It is fairly likely to be a waste of time
  3978. # in most other cases [unless the file happened to be
  3979. # modified in $revision specifically], but
  3980. # it is probably in the noise compared to how long
  3981. # getMetaFromCommithash() will take.
  3982. my $db_query;
  3983. $db_query = $self->{dbh}->prepare_cached(
  3984. "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
  3985. {},1);
  3986. $db_query->execute($filename, $revision);
  3987. $meta = $db_query->fetchrow_hashref;
  3988. if(! $meta)
  3989. {
  3990. my($revCommit)=$self->lookupCommitRef($revision);
  3991. if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
  3992. {
  3993. return $self->getMetaFromCommithash($filename,$revCommit);
  3994. }
  3995. # error recovery: nothing found:
  3996. print "E Failed to find $filename version=$revision\n";
  3997. $log->warning("failed get $revision");
  3998. return $meta;
  3999. }
  4000. }
  4001. else
  4002. {
  4003. my($revCommit)=$self->lookupCommitRef($revision);
  4004. if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
  4005. {
  4006. return $self->getMetaFromCommithash($filename,$revCommit);
  4007. }
  4008. # error recovery: fall back on head version below
  4009. print "E Failed to find $filename version=$revision\n";
  4010. $log->warning("failed get $revision");
  4011. undef $revision; # Allow fallback
  4012. }
  4013. }
  4014. if(!defined($revision))
  4015. {
  4016. my $db_query;
  4017. $db_query = $self->{dbh}->prepare_cached(
  4018. "SELECT * FROM $tablename_head WHERE name=?",{},1);
  4019. $db_query->execute($filename);
  4020. $meta = $db_query->fetchrow_hashref;
  4021. }
  4022. if($meta)
  4023. {
  4024. $meta->{revision} = "1.$meta->{revision}";
  4025. }
  4026. return $meta;
  4027. }
  4028. sub getMetaFromCommithash
  4029. {
  4030. my $self = shift;
  4031. my $filename = shift;
  4032. my $revCommit = shift;
  4033. # NOTE: This function doesn't scale well (lots of forks), especially
  4034. # if you have many files that have not been modified for many commits
  4035. # (each git-rev-parse redoes a lot of work for each file
  4036. # that theoretically could be done in parallel by smarter
  4037. # graph traversal).
  4038. #
  4039. # TODO: Possible optimization strategies:
  4040. # - Solve the issue of assigning and remembering "real" CVS
  4041. # revision numbers for branches, and ensure the
  4042. # data structure can do this efficiently. Perhaps something
  4043. # similar to "git notes", and carefully structured to take
  4044. # advantage same-sha1-is-same-contents, to roll the same
  4045. # unmodified subdirectory data onto multiple commits?
  4046. # - Write and use a C tool that is like git-blame, but
  4047. # operates on multiple files with file granularity, instead
  4048. # of one file with line granularity. Cache
  4049. # most-recently-modified in $self->{commitRefCache}{$revCommit}.
  4050. # Try to be intelligent about how many files we do with
  4051. # one fork (perhaps one directory at a time, without recursion,
  4052. # and/or include directory as one line item, recurse from here
  4053. # instead of in C tool?).
  4054. # - Perhaps we could ask the DB for (filename,fileHash),
  4055. # and just guess that it is correct (that the file hadn't
  4056. # changed between $revCommit and the found commit, then
  4057. # changed back, confusing anything trying to interpret
  4058. # history). Probably need to add another index to revisions
  4059. # DB table for this.
  4060. # - NOTE: Trying to store all (commit,file) keys in DB [to
  4061. # find "lastModfiedCommit] (instead of
  4062. # just files that changed in each commit as we do now) is
  4063. # probably not practical from a disk space perspective.
  4064. # Does the file exist in $revCommit?
  4065. # TODO: Include file hash in dirmap cache.
  4066. my($dirMap)=$self->getRevisionDirMap($revCommit);
  4067. my($dir,$file)=($filename=~m%^(?:(.*)/)?([^/]*$)%);
  4068. if(!defined($dir))
  4069. {
  4070. $dir="";
  4071. }
  4072. if( !defined($dirMap->{$dir}) ||
  4073. !defined($dirMap->{$dir}{$filename}) )
  4074. {
  4075. my($fileHash)="deleted";
  4076. my($retVal)={};
  4077. $retVal->{name}=$filename;
  4078. $retVal->{filehash}=$fileHash;
  4079. # not needed and difficult to compute:
  4080. $retVal->{revision}="0"; # $revision;
  4081. $retVal->{commithash}=$revCommit;
  4082. #$retVal->{author}=$commit->{author};
  4083. #$retVal->{modified}=convertToCvsDate($commit->{date});
  4084. #$retVal->{mode}=convertToDbMode($mode);
  4085. return $retVal;
  4086. }
  4087. my($fileHash) = ::safe_pipe_capture("git","rev-parse","$revCommit:$filename");
  4088. chomp $fileHash;
  4089. if(!($fileHash=~/^[0-9a-f]{$state->{hexsz}}$/))
  4090. {
  4091. die "Invalid fileHash '$fileHash' looking up"
  4092. ." '$revCommit:$filename'\n";
  4093. }
  4094. # information about most recent commit to modify $filename:
  4095. open(my $gitLogPipe, '-|', 'git', 'rev-list',
  4096. '--max-count=1', '--pretty', '--parents',
  4097. $revCommit, '--', $filename)
  4098. or die "Cannot call git-rev-list: $!";
  4099. my @commits=readCommits($gitLogPipe);
  4100. close $gitLogPipe;
  4101. if(scalar(@commits)!=1)
  4102. {
  4103. die "Can't find most recent commit changing $filename\n";
  4104. }
  4105. my($commit)=$commits[0];
  4106. if( !defined($commit) || !defined($commit->{hash}) )
  4107. {
  4108. return undef;
  4109. }
  4110. # does this (commit,file) have a real assigned CVS revision number?
  4111. my $tablename_rev = $self->tablename("revision");
  4112. my $db_query;
  4113. $db_query = $self->{dbh}->prepare_cached(
  4114. "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
  4115. {},1);
  4116. $db_query->execute($filename, $commit->{hash});
  4117. my($meta)=$db_query->fetchrow_hashref;
  4118. if($meta)
  4119. {
  4120. $meta->{revision} = "1.$meta->{revision}";
  4121. return $meta;
  4122. }
  4123. # fall back on special revision number
  4124. my($revision)=$commit->{hash};
  4125. $revision=~s/(..)/'.' . (hex($1)+100)/eg;
  4126. $revision="2.1.1.2000$revision";
  4127. # meta data about $filename:
  4128. open(my $filePipe, '-|', 'git', 'ls-tree', '-z',
  4129. $commit->{hash}, '--', $filename)
  4130. or die("Cannot call git-ls-tree : $!");
  4131. local $/ = "\0";
  4132. my $line;
  4133. $line=<$filePipe>;
  4134. if(defined(<$filePipe>))
  4135. {
  4136. die "Expected only a single file for git-ls-tree $filename\n";
  4137. }
  4138. close $filePipe;
  4139. chomp $line;
  4140. unless ( $line=~m/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
  4141. {
  4142. die("Couldn't process git-ls-tree line : $line\n");
  4143. }
  4144. my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
  4145. # save result:
  4146. my($retVal)={};
  4147. $retVal->{name}=$filename;
  4148. $retVal->{revision}=$revision;
  4149. $retVal->{filehash}=$fileHash;
  4150. $retVal->{commithash}=$revCommit;
  4151. $retVal->{author}=$commit->{author};
  4152. $retVal->{modified}=convertToCvsDate($commit->{date});
  4153. $retVal->{mode}=convertToDbMode($mode);
  4154. return $retVal;
  4155. }
  4156. =head2 lookupCommitRef
  4157. Convert tag/branch/abbreviation/etc into a commit sha1 hash. Caches
  4158. the result so looking it up again is fast.
  4159. =cut
  4160. sub lookupCommitRef
  4161. {
  4162. my $self = shift;
  4163. my $ref = shift;
  4164. my $commitHash = $self->{commitRefCache}{$ref};
  4165. if(defined($commitHash))
  4166. {
  4167. return $commitHash;
  4168. }
  4169. $commitHash = ::safe_pipe_capture("git","rev-parse","--verify","--quiet",
  4170. $self->unescapeRefName($ref));
  4171. $commitHash=~s/\s*$//;
  4172. if(!($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/))
  4173. {
  4174. $commitHash=undef;
  4175. }
  4176. if( defined($commitHash) )
  4177. {
  4178. my $type = ::safe_pipe_capture("git","cat-file","-t",$commitHash);
  4179. if( ! ($type=~/^commit\s*$/ ) )
  4180. {
  4181. $commitHash=undef;
  4182. }
  4183. }
  4184. if(defined($commitHash))
  4185. {
  4186. $self->{commitRefCache}{$ref}=$commitHash;
  4187. }
  4188. return $commitHash;
  4189. }
  4190. =head2 clearCommitRefCaches
  4191. Clears cached commit cache (sha1's for various tags/abbeviations/etc),
  4192. and related caches.
  4193. =cut
  4194. sub clearCommitRefCaches
  4195. {
  4196. my $self = shift;
  4197. $self->{commitRefCache} = {};
  4198. $self->{revisionDirMapCache} = undef;
  4199. $self->{gethead_cache} = undef;
  4200. }
  4201. =head2 commitmessage
  4202. this function takes a commithash and returns the commit message for that commit
  4203. =cut
  4204. sub commitmessage
  4205. {
  4206. my $self = shift;
  4207. my $commithash = shift;
  4208. my $tablename = $self->tablename("commitmsgs");
  4209. die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
  4210. my $db_query;
  4211. $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
  4212. $db_query->execute($commithash);
  4213. my ( $message ) = $db_query->fetchrow_array;
  4214. if ( defined ( $message ) )
  4215. {
  4216. $message .= " " if ( $message =~ /\n$/ );
  4217. return $message;
  4218. }
  4219. my @lines = ::safe_pipe_capture("git", "cat-file", "commit", $commithash);
  4220. shift @lines while ( $lines[0] =~ /\S/ );
  4221. $message = join("",@lines);
  4222. $message .= " " if ( $message =~ /\n$/ );
  4223. return $message;
  4224. }
  4225. =head2 gethistorydense
  4226. This function takes a filename (with path) argument and returns an arrayofarrays
  4227. containing revision,filehash,commithash ordered by revision descending.
  4228. This version of gethistory skips deleted entries -- so it is useful for annotate.
  4229. The 'dense' part is a reference to a '--dense' option available for git-rev-list
  4230. and other git tools that depend on it.
  4231. See also getlog().
  4232. =cut
  4233. sub gethistorydense
  4234. {
  4235. my $self = shift;
  4236. my $filename = shift;
  4237. my $tablename = $self->tablename("revision");
  4238. my $db_query;
  4239. $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
  4240. $db_query->execute($filename);
  4241. my $result = $db_query->fetchall_arrayref;
  4242. my $i;
  4243. for($i=0 ; $i<scalar(@$result) ; $i++)
  4244. {
  4245. $result->[$i][0]="1." . $result->[$i][0];
  4246. }
  4247. return $result;
  4248. }
  4249. =head2 escapeRefName
  4250. Apply an escape mechanism to compensate for characters that
  4251. git ref names can have that CVS tags can not.
  4252. =cut
  4253. sub escapeRefName
  4254. {
  4255. my($self,$refName)=@_;
  4256. # CVS officially only allows [-_A-Za-z0-9] in tag names (or in
  4257. # many contexts it can also be a CVS revision number).
  4258. #
  4259. # Git tags commonly use '/' and '.' as well, but also handle
  4260. # anything else just in case:
  4261. #
  4262. # = "_-s-" For '/'.
  4263. # = "_-p-" For '.'.
  4264. # = "_-u-" For underscore, in case someone wants a literal "_-" in
  4265. # a tag name.
  4266. # = "_-xx-" Where "xx" is the hexadecimal representation of the
  4267. # desired ASCII character byte. (for anything else)
  4268. if(! $refName=~/^[1-9][0-9]*(\.[1-9][0-9]*)*$/)
  4269. {
  4270. $refName=~s/_-/_-u--/g;
  4271. $refName=~s/\./_-p-/g;
  4272. $refName=~s%/%_-s-%g;
  4273. $refName=~s/[^-_a-zA-Z0-9]/sprintf("_-%02x-",$1)/eg;
  4274. }
  4275. }
  4276. =head2 unescapeRefName
  4277. Undo an escape mechanism to compensate for characters that
  4278. git ref names can have that CVS tags can not.
  4279. =cut
  4280. sub unescapeRefName
  4281. {
  4282. my($self,$refName)=@_;
  4283. # see escapeRefName() for description of escape mechanism.
  4284. $refName=~s/_-([spu]|[0-9a-f][0-9a-f])-/unescapeRefNameChar($1)/eg;
  4285. # allowed tag names
  4286. # TODO: Perhaps use git check-ref-format, with an in-process cache of
  4287. # validated names?
  4288. if( !( $refName=~m%^[^-][-a-zA-Z0-9_/.]*$% ) ||
  4289. ( $refName=~m%[/.]$% ) ||
  4290. ( $refName=~/\.lock$/ ) ||
  4291. ( $refName=~m%\.\.|/\.|[[\\:?*~]|\@\{% ) ) # matching }
  4292. {
  4293. # Error:
  4294. $log->warn("illegal refName: $refName");
  4295. $refName=undef;
  4296. }
  4297. return $refName;
  4298. }
  4299. sub unescapeRefNameChar
  4300. {
  4301. my($char)=@_;
  4302. if($char eq "s")
  4303. {
  4304. $char="/";
  4305. }
  4306. elsif($char eq "p")
  4307. {
  4308. $char=".";
  4309. }
  4310. elsif($char eq "u")
  4311. {
  4312. $char="_";
  4313. }
  4314. elsif($char=~/^[0-9a-f][0-9a-f]$/)
  4315. {
  4316. $char=chr(hex($char));
  4317. }
  4318. else
  4319. {
  4320. # Error case: Maybe it has come straight from user, and
  4321. # wasn't supposed to be escaped? Restore it the way we got it:
  4322. $char="_-$char-";
  4323. }
  4324. return $char;
  4325. }
  4326. =head2 in_array()
  4327. from Array::PAT - mimics the in_array() function
  4328. found in PHP. Yuck but works for small arrays.
  4329. =cut
  4330. sub in_array
  4331. {
  4332. my ($check, @array) = @_;
  4333. my $retval = 0;
  4334. foreach my $test (@array){
  4335. if($check eq $test){
  4336. $retval = 1;
  4337. }
  4338. }
  4339. return $retval;
  4340. }
  4341. =head2 mangle_dirname
  4342. create a string from a directory name that is suitable to use as
  4343. part of a filename, mainly by converting all chars except \w.- to _
  4344. =cut
  4345. sub mangle_dirname {
  4346. my $dirname = shift;
  4347. return unless defined $dirname;
  4348. $dirname =~ s/[^\w.-]/_/g;
  4349. return $dirname;
  4350. }
  4351. =head2 mangle_tablename
  4352. create a string from a that is suitable to use as part of an SQL table
  4353. name, mainly by converting all chars except \w to _
  4354. =cut
  4355. sub mangle_tablename {
  4356. my $tablename = shift;
  4357. return unless defined $tablename;
  4358. $tablename =~ s/[^\w_]/_/g;
  4359. return $tablename;
  4360. }
  4361. 1;