Warning, file /sdk/kde-dev-scripts/kde-checkout-list.pl was not indexed or was modified since last indexation (in which case cross-reference links may be missing, inaccurate or erroneous).

0001 #!/usr/bin/perl -w
0002 # -*- cperl-indent-level: 2 -*-
0003 ###############################################################################
0004 # Parses the KDE Projects XML Database and prints project protocol-url lines  #
0005 # for each project in the specified component/module.                         #
0006 #                                                                             #
0007 # Copyright (C) 2011,2012,2014,2017 by Allen Winter <winter@kde.org>          #
0008 # Copyright (C) 2011 by David Faure <faure@kde.org>                           #
0009 #                                                                             #
0010 # This program is free software; you can redistribute it and/or modify        #
0011 # it under the terms of the GNU General Public License as published by        #
0012 # the Free Software Foundation; either version 2 of the License, or           #
0013 # (at your option) any later version.                                         #
0014 #                                                                             #
0015 # This program is distributed in the hope that it will be useful,             #
0016 # but WITHOUT ANY WARRANTY; without even the implied warranty of              #
0017 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the                #
0018 # GNU General Public License for more details.                                #
0019 #                                                                             #
0020 # You should have received a copy of the GNU General Public License along     #
0021 # with this program; if not, write to the Free Software Foundation, Inc.,     #
0022 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.                #
0023 ###############################################################################
0024 
0025 # TODO
0026 # - validation (once a DTD is available)
0027 
0028 use strict;
0029 use Getopt::Long;
0030 use XML::Parser;
0031 use LWP::Simple;                # used to fetch the xml db
0032 
0033 my($Prog) = 'kde-checkout-list.pl';
0034 my($Version) = '0.97';
0035 
0036 my($help) = '';
0037 my($version) = '';
0038 my($searchComponent) = '';
0039 my($searchModule) = '';
0040 my($searchProtocol) = "git";
0041 my($allmatches) = 0;
0042 my($printDesc) = 0;
0043 my($doClone) = 0;
0044 my($doPrune) = 0;
0045 my($dryRun) = 0;
0046 my($quitOnError) = 0;
0047 my($gitSuffix) = 0;
0048 my($branch) = '';
0049 
0050 exit 1
0051 if (!GetOptions('help' => \$help, 'version' => \$version,
0052                 'component=s' => \$searchComponent,
0053                 'module=s' => \$searchModule,
0054                 'protocol=s' => \$searchProtocol,
0055                 'all' => \$allmatches,
0056                 'desc' => \$printDesc,
0057                 'clone' => \$doClone,
0058                 'prune' => \$doPrune,
0059                 'dry-run' => \$dryRun,
0060                 'quit-on-error' => \$quitOnError,
0061                 'gitsuffix' => \$gitSuffix,
0062                 'branch=s' => \$branch
0063                ));
0064 
0065 &Help() if ($help);
0066 
0067 if ($searchProtocol ne "git" &&
0068     $searchProtocol ne "http" &&
0069     $searchProtocol ne "ssh" &&
0070     $searchProtocol ne "tarball") {
0071   print "Invalid protocol \"$searchProtocol\" specified.\n";
0072   print "Run $Prog --help for more info\n";
0073   exit 1;
0074 }
0075 &Version() if ($version);
0076 
0077 if ($searchModule && !$searchComponent) {
0078   print "Module specified, but not in which component. Please use --component kde for instance.\n";
0079   print "Run $Prog --help for more info\n";
0080   exit 1;
0081 }
0082 
0083 my $kdebranch='';
0084 my $kdedash='';
0085 if ($branch) {
0086   $kdebranch = "KDE/" . $branch;
0087   $kdedash = "kde-" . $branch;
0088 }
0089 
0090 my $curComponent = "";
0091 my $curModule = "";
0092 my $curProject = "";
0093 my $curPath = "";
0094 my $curUrl = "";
0095 my $curActive = 1;
0096 my $curDesc = "";
0097 my $skipModule = 0;
0098 my $inRepo = 0;
0099 my $inPath = 0;
0100 my $inUrl = 0;
0101 my $inActive = 0;
0102 my $inDesc = 0;
0103 
0104 my @element_stack;              # remember which elements are open
0105 my %output;         # project name -> project data
0106 my %projectByPath;  # project path -> project name
0107 
0108 my $projects = get("https://projects.kde.org/kde_projects.xml");
0109 die "Failed to download kde_projects.xml" unless defined $projects;
0110 
0111 # sanity check
0112 my @lines = split('\n',$projects);
0113 if ($lines[0] !~ m/xml version/ || $lines[$#lines] !~ m+</kdeprojects>+) {
0114   print "The kde_projects.xml downloaded is invalid somehow. Try again\n";
0115   exit 1;
0116 }
0117 
0118 # initialize the parser
0119 my $parser = XML::Parser->new( Handlers =>
0120                                {
0121                                 Start=>\&handle_start,
0122                                 End=>\&handle_end,
0123                                 Char=>\&char_handler,
0124                                 });
0125 
0126 $parser->parse( $projects );
0127 
0128 # print results
0129 my($proj,$ret);
0130 foreach $proj (sort keys %output) {
0131   if ( $output{$proj}{'active'} || $allmatches ) {
0132     my $subdir = $output{$proj}{'path'};
0133     my $url = $output{$proj}{'url'};
0134     my $desc = "";
0135     if ( defined($output{$proj}{'desc'}) ) {
0136       $desc = $output{$proj}{'desc'};
0137     }
0138     if ( !$printDesc ) {
0139       print "$subdir $url\n";
0140     } else {
0141       print "$subdir $url $desc\n";
0142     }
0143 
0144     if ( $doClone ) {
0145       my $command;
0146       my $newCheckout = 0;
0147       if ( ! -d "$subdir" ) {
0148         $newCheckout = 1;
0149 #modules without the "KDE/" in the branchname are:
0150 # kdebase/kate => only KDE/4.7 and above
0151 # kdeexamples => No branches
0152 # superbuild => No branches
0153 
0154         if ( $branch ) {
0155           next if ( $subdir =~ m+/kdeexamples+ || $subdir =~ m+/superbuild+ );
0156           if ( $subdir !~ m+/kdelibs+ ) {
0157             $command = "git clone -b $kdebranch --single-branch $url $subdir && cd $subdir && git checkout $kdebranch";
0158 #            $command = "git clone $url $subdir && cd $subdir && git checkout -b $kdebranch origin/$kdebranch";
0159           } else {
0160             $command = "git clone $url $subdir && cd $subdir && git checkout $kdebranch";
0161           }
0162         } else {
0163           $command = "git clone $url $subdir";
0164         }
0165       } else {
0166         if ($branch) {
0167           next if ( $subdir =~ m+/kdeexamples+ || $subdir =~ m+/superbuild+ );
0168           $command = "cd $subdir && git config remote.origin.url $url && git checkout $kdebranch && git pull --ff";
0169         } else {
0170           $command = "cd $subdir && git config remote.origin.url $url && git pull --ff";
0171         }
0172       }
0173       $ret = &runCommand( $command );
0174       if ($ret) {
0175         #check if there is a branch by this name in the repo. If not, then no error.
0176         my($ohno) = 1;
0177         if (-d "$subdir/.git" && $branch) {
0178           $ret = &runCommand( "cd $subdir && git checkout $kdebranch" );
0179           if ($ret) {
0180             $ohno = 0;
0181           }
0182         }
0183         if ($newCheckout) {
0184             printf "REMOVING CLONE DUE TO GIT FAILURE\n";
0185             runCommand("rm -rf $subdir");
0186         }
0187         if ($ohno) {
0188           if ($quitOnError) {
0189             printf "Exiting due to quit-on-error option\n";
0190           } else {
0191             printf "Continuing anyway\n"
0192           }
0193         } else {
0194           printf "FYI: $subdir does not have a branch called $kdebranch. Continuing normally\n"
0195         }
0196       }
0197     }
0198   }
0199 }
0200 
0201 # wipe out old checkouts, if requested
0202 if ( $doPrune ) {
0203   my $startDir = ".";
0204   if ( $searchComponent ) {
0205     $startDir = $searchComponent;
0206     if ($branch) {
0207       my $foo = $searchComponent . "-" . $branch;
0208       $startDir =~ s+$searchComponent+$foo+;
0209     }
0210     if ( $searchModule ) {
0211       $startDir .= "/$searchModule";
0212     }
0213   }
0214   if ( -d $startDir ) {
0215     open(my $F, "find $startDir -name .git |");
0216     while (my $line = <$F>) {
0217       chomp $line;
0218       $line =~ s,/\.git,,;
0219       $line =~ s,^\./,,;
0220       if ( not exists $projectByPath{$line} ) {
0221         print STDERR "Deleting old git checkout: $line\n";
0222         runCommand( "rm -rf \"$line\"" );
0223       }
0224     }
0225   }
0226 }
0227 
0228 sub runCommand {
0229   my ( $command ) = @_;
0230   my $ret = 0;
0231   if ( $dryRun ) {
0232     print STDERR "$command\n";
0233   } else {
0234     $ret = system( $command );
0235     $ret = $ret >> 8;
0236   }
0237   return $ret;
0238 }
0239 
0240 # process a start-of-element event: print message about element
0241 #
0242 sub handle_start {
0243   my( $expat, $element, %attrs ) = @_;
0244 
0245   # ask the expat object about our position
0246   my $line = $expat->current_line;
0247 
0248   # remember this element and its starting position by pushing a
0249   # little hash onto the element stack
0250   push( @element_stack, { element=>$element, line=>$line });
0251 
0252   #print STDERR "-- $element\n";
0253 
0254   if ( $element eq "component" ) {
0255     my $value = $attrs{"identifier"};
0256     #print STDERR "component identifier=$value\n";
0257     if ( (!$searchComponent or ($value eq $searchComponent)) ) {
0258       $curComponent = $value;
0259       $curModule = "";
0260       $curProject = "";
0261       $inRepo = 0;
0262 
0263       #print STDERR "BEGIN component $curComponent.\n";
0264     }
0265   }
0266 
0267   if ( $curComponent && $element eq "module" ) {
0268     my $value = $attrs{"identifier"};
0269     $curProject = "";
0270     if ( !$searchModule or ($value eq $searchModule) ) {
0271       $curModule = $value;
0272       #print STDERR "BEGIN module $curModule\n";
0273       $skipModule = 0;
0274     } else {
0275       $skipModule = 1;
0276       #print STDERR "SKIP module $value\n";
0277     }
0278   }
0279 
0280   if ( $curComponent && !$skipModule && $element eq "project" ) {
0281     $curProject = $attrs{"identifier"};
0282     if (!$curModule) {
0283       #print STDERR "project without a module! $curProject\n";
0284     }
0285     #print STDERR "BEGIN project $curProject\n";
0286   }
0287 
0288   if ($curComponent && !$skipModule) {
0289     if ( $element eq "path" ) {
0290       $inPath = 1;
0291     } elsif ( $element eq "repo" ) {
0292       $inRepo = 1;
0293       $curActive = 1; # assume all repos are active by default
0294     } elsif ( $inRepo && $element eq "url" ) {
0295       my $value = $attrs{"protocol"};
0296       if ( $value eq $searchProtocol ) {
0297         $inUrl = 1;
0298       }
0299     } elsif ( $inRepo && $element eq "active" ) {
0300       $inActive = 1;
0301     } elsif ( $element eq "description" ) {
0302       $inDesc = 1;
0303     }
0304   }
0305 }
0306 
0307 # process an end-of-element event
0308 #
0309 sub handle_end {
0310   my( $expat, $element ) = @_;
0311 
0312   # We'll just pop from the element stack with blind faith that
0313   # we'll get the correct closing element, since XML::Parser will scream
0314   # bloody murder if any well-formedness errors creep in.
0315   my $element_record = pop( @element_stack );
0316 
0317   if ( $element eq "component" && $curComponent ) {
0318     #print "END of component $curComponent\n";
0319     $curComponent = "";
0320   }
0321   if ( $element eq "module" && $curComponent && $curModule ) {
0322     #print "END of module $curModule\n";
0323     $curModule = "";
0324   }
0325   if ( $element eq "project" && $curComponent && $curModule && $curProject ) {
0326     #print "END of project $curProject\n";
0327     $curProject = "";
0328     $curUrl = "";
0329   }
0330   if ( $element eq "repo" && $curComponent && $inRepo ) {
0331     #print STDERR "repo in $curPath: $curUrl\n";
0332     $inRepo = 0;
0333     if ( $curUrl && $curPath ) {
0334       if ($branch) {
0335         my $foo = $curComponent . "-" . $branch;
0336         $curPath =~ s+$curComponent+$foo+;
0337       }
0338       my $subdir = $curPath;
0339       $curPath .= "-git" if ($gitSuffix && -d "$curPath/.svn");
0340       # $subdir is the logical name (extragear/network/konversation)
0341       # while $curPath is the physical path (extragear/network/konversation-git)
0342       $output{$subdir}{'path'} = $curPath;
0343       $output{$subdir}{'url'} = $curUrl;
0344       $output{$subdir}{'active'} = $curActive;
0345       $output{$subdir}{'desc'} = $curDesc;
0346       $curDesc = "";
0347       $projectByPath{$curPath} = $subdir;
0348     } else {
0349       if (!$curUrl) {
0350         print STDERR "ERROR: repo without url! $curComponent $curModule $curProject $curPath\n";
0351       } elsif (!$curPath) {
0352         print STDERR "ERROR: repo without path! $curComponent $curModule $curProject $curUrl\n";
0353       }
0354     }
0355   }
0356   if ( $element eq "path" ) {
0357     $inPath = 0;
0358   } elsif ( $element eq "url" ) {
0359     $inUrl = 0;
0360   } elsif ( $element eq "active" ) {
0361     $inActive = 0;
0362   } elsif ( $element eq "description" ) {
0363     $inDesc = 0;
0364   }
0365 }
0366 
0367 sub char_handler
0368 {
0369   my ($p, $data) = @_;
0370 
0371   $data =~ s/\n/\n\t/g;
0372   if ( $inPath ) {
0373     $curPath = $data;
0374   } elsif ( $inUrl ) {
0375     $curUrl = $data;
0376   } elsif ( $inActive ) {
0377     $curActive = !( $data =~ m/false/i || $data =~ m/off/i );
0378   } elsif ( $inDesc && !$curDesc ) {
0379     if ( $data !~ m/^\s*$/ ) {
0380       $curDesc = $data;
0381     }
0382   }
0383 
0384 }  # End of default_handler
0385 
0386 # Help function: print help message and exit.
0387 sub Help {
0388   &Version();
0389   print "Parses the KDE Projects XML Database and prints project protocol-url lines\n";
0390   print "for each project in the specified component/module.\n\n";
0391   print "  --help        display help message and exit\n";
0392   print "  --version     display version information and exit\n";
0393   print "  --component   search for projects within this component\n";
0394   print "  --module      search for projects within this module (requires --component)\n";
0395   print "  --branch      git checkout the specified branch, i.e. 4.6\n";
0396   print "  --protocol    print the URI for the specified protocol (default=\"git\")\n";
0397   print "                possible values are \"git\", \"http\", \"ssh\" or \"tarball\"\n";
0398   print "  --all         print all projects, not just active-only projects\n";
0399   print "  --desc        print the project description too\n";
0400   print "\n";
0401   print "  --clone       actually do a git clone or pull of every repo found\n";
0402   print "      Note: this is meant for servers like lxr/ebn rather than for developers.\n";
0403   print "  --gitsuffix   append '-git' to the directory name when cloning, if a svn dir exists.\n";
0404   print "  --prune       remove old git checkouts that are not listed anymore\n";
0405   print "  --dry-run     show git and prune commands but don't execute them.\n";
0406   print "\n";
0407   print "Examples:\n\n";
0408   print "To print the active projects in extragear network with git protocol:\n";
0409   print "% $Prog --component=extragear --module=network\n";
0410   print "\n";
0411   print "To print all projects in playground utils with the ssh protocol:\n";
0412   print "% $Prog --component=playground --module=utils --protocol=ssh --all\n";
0413   print "\n";
0414   exit 0 if $help;
0415 }
0416 
0417 # Version function: print the version number and exit.
0418 sub Version {
0419   print "$Prog, version $Version\n";
0420   exit 0 if $version;
0421 }