Git-Url: http://git.frugalware.org/gitweb/gitweb.cgi?p=pacman-tools.git;a=commitdiff;h=6b6bad78b8d9028c298587904a0f6521c8e7e670
commit 6b6bad78b8d9028c298587904a0f6521c8e7e670 Author: VMiklos <[EMAIL PROTECTED]> Date: Sun Sep 30 23:16:39 2007 +0200 rf: bin, obsolete diff --git a/rf b/rf deleted file mode 100644 index beecc53..0000000 --- a/rf +++ /dev/null @@ -1,752 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - - rf - RepomanFrontend - -=head1 DESCRIPTION - -rf operates with actions, namely, Record, Cleanup, Push, Upload, cL. -If you don't specify non of these actioons, with the marked switch -(eg. for repoman cl it is -L), -RCPUL will be used. -it is trying to guess as many data as needed for the specified -actions, or you can pass them with non capital swithes. -Usually -f and -s are enough to do a whole upgrade. -Run it from the packages darcs directory. - -=head1 OPTIONS - -=over 1 - -=head2 ACTIONS - -=item B<-H> - - runs a FrugalBuild checking, before recording. - Can be overridden, with actions -RCPUL - -=item B<-R> - - darcs record your patch - -=item B<-C> - - Cleanup on the server - -=item B<-P> - - darcs push your patch - -=item B<-U> - - Upload the given source and package files - -=item B<-L> - - repoman cl aka generate the Changelog file - -=item B<-W> - - A warning message before doing anything - -=item B<-h> - - Help - -=item B<-r> - - Specify the repository eg. extra - if not given, default will be used. - -=item B<-a> - - Architecture, default is i686. - -=item B<-o> - - The directory of the repo, where the fpms are. - Default is frugalware-$arch. - -=item B<-p> - - Serverprefix, eg. - ftp://ftp.frugalware.org/pub/frugalware/frugalware-current/ - also this is the default. - -=item B<-g> - - Group of the package, meaning the physical group, eg. the - /extra/devel/adevelpkg has devel group. - -=item B<-m> - - Don't run fblint. - -=item B<-n> - - Name of the package - -=item B<-t> - - Version if the package - -=item B<-l> - - Release of the package - -=item B<-s> - - New sourcefile - -=item B<-f> - - New packagefile - -=item B<-q> - - Do not look for old source and package. - Useful when you contribute a new package. - -=item B<-v> - - Version of the distribution, default is current. - -=item B<-d> - - Delete the files given in -s and -f - -=item B<-c> - - Try to delete the sources, too. - -=item B<-k> - - Answer yes to all questions. - -=head1 CHANGES - -=head2 0.6 - - Release as stable - darcs and -k bugfix - new getopts method - but still not good enough! - fblint check - nobuild option handling - use of 'repoman ls' - more little bugfixes - -=head2 0.5 - - Release as stable - pkgver and pkgrel gathering bugfix - New 'a' keyselection - More options in man page - -=head2 0.4 - - Action driven usage - $arch fixes - -=head2 0.3 - - Sourcefile must contain 'tar'. - Inform of use of -d - asking done with readkey - no more enter hit - -=head1 BUGS - - Report bugs, patches, comments, patches and - funny quotes in your signature to - <[EMAIL PROTECTED]> - -=head1 AUTHOR - - Zsolt Szalai <[EMAIL PROTECTED]> - -=head1 COPYRIGHT - - rf may be copied and modified under the terms of the - GNU General Public License v2 - -=cut - - -package Getopts; -require 5.000; -require Exporter; - -=head1 NAME - -getopt, getopts - Process single-character switches with switch clustering - -=head1 SYNOPSIS - - use Getopts; - - getopt('oDI'); # -o, -D & -I take arg. Sets $opt_* as a side effect. - getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts - getopts('oif:'); # -o & -i are boolean flags, -f takes an argument - # Sets $opt_* as a side effect. - getopts('oif:', \%opts); # options as above. Values in %opts - -=head1 DESCRIPTION - -The getopt() function processes single-character switches with switch -clustering. Pass one argument which is a string containing all switches -that take an argument. For each switch found, sets $opt_x (where x is the -switch name) to the value of the argument if an argument is expected, -or 1 otherwise. Switches which take an argument don't care whether -there is a space between the switch and the argument. - -The getopts() function is similar, but you should pass to it the list of all -switches to be recognized. If unspecified switches are found on the -command-line, the user will be warned that an unknown option was given. - -Note that, if your code is running under the recommended C<use strict -'vars'> pragma, you will need to declare these package variables -with "our": - - our($opt_x, $opt_y); - -For those of you who don't like additional global variables being created, getopt() -and getopts() will also accept a hash reference as an optional second argument. -Hash keys will be x (where x is the switch name) with key values the value of -the argument or 1 if no argument is specified. - -To allow programs to process arguments that look like switches, but aren't, -both functions will stop processing switches when they see the argument -C<-->. The C<--> will be removed from @ARGV. - -=head1 C<--help> and C<--version> - -If C<-> is not a recognized switch letter, getopts() supports arguments -C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or -C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are -the output file handle, the name of option-processing package, its version, -and the switches string. If the subroutines are not defined, an attempt is -made to generate intelligent messages; for best results, define $main::VERSION. - -If embedded documentation (in pod format, see L<perlpod>) is detected -in the script, C<--help> will also show how to access the documentation. - -Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION -isn't true (the default is false), then the messages are printed on STDERR, -and the processing continues after the messages are printed. This being -the opposite of the standard-conforming behaviour, it is strongly recommended -to set $Getopt::Std::STANDARD_HELP_VERSION to true. - -One can change the output file handle of the messages by setting -$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help> -(without the C<Usage:> line) and C<--version> by calling functions help_mess() -and version_mess() with the switches string as an argument. - -=cut - [EMAIL PROTECTED] = qw(Exporter); [EMAIL PROTECTED] = qw(getopt getopts); -$VERSION = '1.05'; -# uncomment the next line to disable 1.03-backward compatibility paranoia -# $STANDARD_HELP_VERSION = 1; - -# Process single-character switches with switch clustering. Pass one argument -# which is a string containing all switches that take an argument. For each -# switch found, sets $opt_x (where x is the switch name) to the value of the -# argument, or 1 if no argument. Switches which take an argument don't care -# whether there is a space between the switch and the argument. - -# Usage: -# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. - -sub getopt (;$$) { - my ($argumentative, $hash) = @_; - $argumentative = '' if !defined $argumentative; - my ($first,$rest); - local $_; - local @EXPORT; - - while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { - ($first,$rest) = ($1,$2); - if (/^--$/) { # early exit if -- - shift @ARGV; - last; - } - if (index($argumentative,$first) >= 0) { - if ($rest ne '') { - shift(@ARGV); - } - else { - shift(@ARGV); - $rest = shift(@ARGV); - } - if (ref $hash) { - $$hash{$first} = $rest; - } - else { - ${"opt_$first"} = $rest; - push( @EXPORT, "\$opt_$first" ); - } - } - else { - if (ref $hash) { - $$hash{$first} = 1; - } - else { - ${"opt_$first"} = 1; - push( @EXPORT, "\$opt_$first" ); - } - if ($rest ne '') { - $ARGV[0] = "-$rest"; - } - else { - shift(@ARGV); - } - } - } - unless (ref $hash) { - local $Exporter::ExportLevel = 1; - import Getopts; - } -} - -sub output_h () { - return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION; - return \*STDOUT if $STANDARD_HELP_VERSION; - return \*STDERR; -} - -sub try_exit () { - exit 0 if $STANDARD_HELP_VERSION; - my $p = __PACKAGE__; - print {output_h()} <<EOM; - [Now continuing due to backward compatibility and excessive paranoia. - See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.] -EOM -} - -sub version_mess ($;$) { - my $args = shift; - my $h = output_h; - if (@_ and defined &main::VERSION_MESSAGE) { - main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args); - } else { - my $v = $main::VERSION; - $v = '[unknown]' unless defined $v; - my $myv = $VERSION; - $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION; - my $perlv = $]; - $perlv = sprintf "%vd", $^V if $] >= 5.006; - print $h <<EOH; -$0 version $v calling Getopt::Std::getopts (version $myv), -running under Perl version $perlv. -EOH - } -} - -sub help_mess ($;$) { - my $args = shift; - my $h = output_h; - if (@_ and defined &main::HELP_MESSAGE) { - main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args); - } else { - my (@witharg) = ($args =~ /(\S)\s*:/g); - my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g); - my ($help, $arg) = ('', ''); - if (@witharg) { - $help .= "\n\tWith arguments: -" . join " -", @witharg; - $arg = "\nSpace is not required between options and their arguments."; - } - if (@rest) { - $help .= "\n\tBoolean (without arguments): -" . join " -", @rest; - } - my ($scr) = ($0 =~ m,([^/\\]+)$,); - print $h <<EOH if @_; # Let the script override this - -Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...] -EOH - print $h <<EOH; - -The following single-character options are accepted:$help - -Options may be merged together. -- stops processing of options.$arg -EOH - my $has_pod; - if ( defined $0 and $0 ne '-e' and -f $0 and -r $0 - and open my $script, '<', $0 ) { - while (<$script>) { - $has_pod = 1, last if /^=(pod|head1)/; - } - } - print $h <<EOH if $has_pod; - -For more details run - perldoc -F $0 -EOH - } -} - -# Usage: -# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a -# # side effect. - -sub getopts ($;$) { - my ($argumentative, $hash) = @_; - my (@args,$first,$rest,$exit,$next); - my $errs = 0; - local $_; - local @EXPORT; - - @args = split( / */, $argumentative ); - while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) { - ($first,$rest) = ($1,$2); - if (/^--$/) { # early exit if -- - shift @ARGV; - last; - } - my $pos = index($argumentative,$first); - if ($pos >= 0) { - if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { - shift(@ARGV); - if ($rest eq '') { - ++$errs unless @ARGV; -# $rest = shift(@ARGV); - while (@ARGV && ($next = shift(@ARGV)) !~ /^(-.)/) {$rest .= $next . ' ';} - chop $rest; - unshift @ARGV, $next; - } - if (ref $hash) { - $$hash{$first} = $rest; - } - else { - ${"opt_$first"} = $rest; - push( @EXPORT, "\$opt_$first" ); - } - } - else { - if (ref $hash) { - $$hash{$first} = 1; - } - else { - ${"opt_$first"} = 1; - push( @EXPORT, "\$opt_$first" ); - } - if ($rest eq '') { - shift(@ARGV); - } - else { - $ARGV[0] = "-$rest"; - } - } - } - else { - if ($first eq '-' and $rest eq 'help') { - version_mess($argumentative, 'main'); - help_mess($argumentative, 'main'); - try_exit(); - shift(@ARGV); - next; - } elsif ($first eq '-' and $rest eq 'version') { - version_mess($argumentative, 'main'); - try_exit(); - shift(@ARGV); - next; - } - warn "Unknown option: $first\n"; - ++$errs; - if ($rest ne '') { - $ARGV[0] = "-$rest"; - } - else { - shift(@ARGV); - } - } - } - unless (ref $hash) { - local $Exporter::ExportLevel = 1; - import Getopts; - } - $errs == 0; -} - -package main; - -use strict; -no warnings qw(uninitialized); - -use Data::Dumper; -use LWP::Simple; -use Cwd; -#use Getopts; -use Term::ReadLine; -use IO::File; -eval {require Term::ReadLine::Gnu}; die 'Please install perl-term-readline-gnu!' if $@; -eval {require Term::ReadKey}; die 'Please install perl-term-readkey!' if $@; -import Term::ReadKey; - -#$Getopt::Std::STANDARD_HELP_VERSION = 1; -our $VERSION = "0.6"; - -sub HELP_MESSAGE(){ - print <<END - rf [-RCPULH] [-s source1 source2 ...] [-f package1 package2] [-d] [-q] [-k] [-n name] -END -} - -sub contents { - my $name = shift; - unless (-e $name || -r $name) { - die "No $name found, or don't have the rights. Are you in a package's directory?"; - } - my $sfh = IO::File->new( "< $name" ); - local $/ = undef; - my $cont = $sfh->getline; - $sfh->close; - return $cont; -} - -my $chkonce = 0; -my %opts; -Getopts::getopts('chmr:a:o:p:g:n:s:f:v:dqkt:l:WRCPULHF', \%opts); - -HELP_MESSAGE && die if $opts{h}; - -$opts{R}=$opts{C}=$opts{P}=$opts{U}=$opts{L}=$opts{H}=$opts{F} = 1 unless $opts{R}|| $opts{C}||$opts{P}||$opts{U}||$opts{L}||$opts{H}||$opts{F}; -$chkonce = 1 if $opts{m}; - -my ($distrib,$version,$repo,$arch, $repodir, $serverprefix, $group, $pkgname, $noask) = - ('frugalware',$opts{v},undef,$opts{a}, $opts{o}, $opts{p}, $opts{g}, $opts{n}, $opts{k}); - -my @sourcefiles = split ' ', $opts{'s'}; -my @pkgfiles = split ' ', $opts{'f'}; -my ($pkgver, $pkgrel); - -sub msystem{ - system @_; - warn 'Failed to execute!' if $? == -1; - return $?>>8; -} - -sub getcommand{ - my $str = shift; - my $term = new Term::ReadLine 'getcommand'; - return $term->readline('>',$str) -} - -sub ask{ - my $str = shift; - return 'y' if $noask; - print "$str "; - my $key; - ReadMode(4); - $key = ReadKey(); - ReadMode(0); - print "$key\n"; - return $key; -} - -sub apply{ - my $comm = shift; - my $exitcode; - APP: - if ((my $an = ask "$comm\n Is this ok? [yagq?]") =~ /^y|^$/i){ - $exitcode = msystem $comm; - } elsif ($an =~ /^a/i){ - $noask = 1; - $exitcode = msystem $comm; - } elsif ($an =~ /^g/i){ - $exitcode = msystem getcommand($comm); - } elsif ($an =~ /^q/i){ - exit; - } elsif ($an =~ /^\?/){ - print "y apply command\na: yes to all further question\ng: give a new command\nq: quit\n\n"; - undef $an; - goto APP; - } - print "\n"; - return $exitcode; -} - -$repo = '' || $opts{r}; -$repo = 'extra' if getcwd =~ m!/extra/!; - -$version = 'current' unless $version; #no need :) -$arch = qx/arch/ and chomp $arch unless $arch; - -$repodir = "$distrib-$arch" unless $repodir; -$serverprefix = "ftp://ftp.$distrib.org/pub/$distrib/$distrib-$version/";; - -unless ( ($group) = getcwd =~ m!.*/(.*?)/[^/]*\Z! ){ - $group = $opts{g}; -} -HELP_MESSAGE && die 'No physical group given!' unless $group; - -($pkgname) = getcwd =~ m!/([^/]*)\Z! unless $pkgname; - -#unless ($pkgname) {($pkgname)= $pkgfiles[0] =~ /^(.*)-.*?-.*?-.*?fpm\Z/{ - -HELP_MESSAGE && die 'Can not determine pkgname!' unless $pkgname; - -my $buildscript = contents 'FrugalBuild'; - -$opts{L} = 0 if $buildscript =~ /^nobuild=|^options.*?nobuild/m; - -$buildscript = contents 'FrugalBuild'; -($pkgver) = qx'source /usr/lib/frugalware/fwmakepkg;source ./FrugalBuild; echo -n $pkgver'; -($pkgrel) = qx'source /usr/lib/frugalware/fwmakepkg;source ./FrugalBuild; echo -n $pkgrel'; - -($pkgver,$pkgrel) = $pkgfiles[0] =~ /^.*-(.*?)-(.*?)-.*?fpm\Z/ unless $pkgver || $pkgrel; - -$pkgver = $opts{t} if $opts{t}; -$pkgrel = $opts{l} if $opts{l}; - -my $subg = 0; -if ($buildscript =~ /subgroup.*?-extra/m) {$subg++;} - -my $oldfpm; - -sub getoldsource{ -#OBSOLETE - my ($url,$sourcefile)= @_; - my ($sn) = $sourcefile =~ /(.*)-/; - if (get($url) =~ /(\Q$sn\E.*?tar.*?)\s/) { - return $1; - } - return 0; -} - -sub getoldfpm{ - my ($url,$pkgname)= @_; - if (qx"repoman -t $version ls $repo/$repodir" =~ /^(\Q$pkgname\E-[^-]*?-[^-]*?-[^-]*?fpm)\s/sm) { - return $1; - } - return 0; -} - -sub ChkFB { - return 0 if $chkonce; - $chkonce = 1 unless $chkonce; # dont want to see suck a thing! - print "Checking FrugalBuild... "; - my @fblint = grep {/\.\.\. failed./} qx/fblint/; - do { print "\n", @fblint; return 1; } if @fblint; - print "Ok\n"; return 0; -} - -sub Record{ - die if ChkFB; - print "Recording your improvements\n"; - HELP_MESSAGE && die 'Can not determine pkgver!' unless $pkgver; - HELP_MESSAGE && die 'Can not determine pkgrel!' unless $pkgrel; - my $ec = apply "darcs record --edit-long-comment -m '$pkgname-$pkgver-$pkgrel-$arch'" . ($noask? ' -a' : '').' .'; - die "Recording FAILED!\n" if $ec == 1; -} - -sub Push{ - print "Pushing the patch\n"; - my $modpkgname = $pkgname; - $modpkgname =~ s/\+/\\\+/g; - my $ec = apply "darcs push --match 'name $modpkgname'" . ($noask? ' -a' : ''); - die "Pushing FAILED!\n" if $ec == 1; -} - -sub UploadFPM{ - my ($ec,$ev); - - print "Getting old FPM...\n"; - if (@pkgfiles){ - for my $pkgfile (@pkgfiles){ - $pkgfile =~ /^(.*)-.*?-.*?-.*?fpm\Z/; - print "Something nasty with $pkgfile, is it a package file?" unless $1; - if( $oldfpm = getoldfpm("$serverprefix/$repo/$repodir/",$1) ){ - print "Ok\n"; - } else { print "Failed! Don`t forget to modify the delete command!\n"; } - } - } else { # at least try to notice old fpm - if( $oldfpm = getoldfpm("$serverprefix/$repo/$repodir/",$pkgname) ){ - print "Ok\n"; - } else { print "Can't see the old package file!\n"; } - } - - print "Uploading binary package\n"; - print "Nothing to do, that's fine!\n\n" unless @pkgfiles; - for my $pkgfile (@pkgfiles){ - #my $repo_ = "extra" if(qx/LANG= LC_ALL= pacman -Qi -p $pkgfile/ =~ /Groups.*-extr$ - $ev = apply "repoman -t $version up $pkgfile /$repodir/" if $pkgfile; - } - die "Uploading FAILED!" if $ev; -} - -sub UploadSRC{ - my ($ec,$ev); - print "Uploading source package\n"; - print "Nothing to do, that's fine!\n\n" unless @sourcefiles; - for my $sourcefile (@sourcefiles){ - $ec = apply "repoman -t $version up $sourcefile $repo/source/$group/$pkgname/" if $sourcefile; - } - die "Uploading FAILED!" if $ec; -} - -sub cL{ - print "Generating ChangeLog\n"; - $repo.='/' if $repo; - my $ec = apply "arch=$arch repoman -t $version cl $repo$group/$pkgname"; - die "Changelog not generated!" if $ec; -} - -sub Cleanup{ - my ($ec,$ev,$ir); - unless ($opts{'q'}){ - if ($opts{'c'}){ - print "Cleanup on server\n"; - my $repo_=$repo . '/' if $repo; - # print "Nothing to do, that's fine!\n\n" unless @sourcefiles || @pkgfiles; - # if (@sourcefiles){ - my (@indarcs) = qx"repoman -t $version ls _darcs/current/$repo_/source/$group/$pkgname/ 2>&1"; - my (@inrepo) = qx"repoman -t $version ls $repo_/source/$group/$pkgname/ 2>&1"; - if ($inrepo[1] =~ 'No such file or') { - print "Probably it is a new package, passing by...\n"; - return; - } - splice(@inrepo,0,1); - @inrepo = grep $_ ne "Changelog\n",@inrepo; - foreach $ir (@inrepo){ - unless(scalar grep(/\Q$ir\E/, @indarcs)){ - $ec = apply "repoman -t $version del $repo/source/$group/$pkgname/$ir"; - } - } - } - - $ev = apply "repoman -t $version del $repo/$repodir/$oldfpm"; - } - die "Cleaning up FAILED!" if $ec||$ev; -} - - -sub Warning { - print "What have you been hacking today?\n"; - unless ((my $what = qx"darcs what -s .") =~ /\QNo changes!\E/){ - print $what; - exit unless (my $an = ask 'Have you checked your package? Everything is ok with it?') =~ /^y|^$/i; - } else {print "Nothing!\n"} -} - -Warning if $opts{W}; -do { die if ChkFB } if $opts{H}; -Record if $opts{R}; -UploadFPM if $opts{F}; -Cleanup if $opts{C}; -Push if $opts{P}; -UploadSRC if $opts{U}; -cL if $opts{L}; - -if ($opts{d}){ #delete source & fpm doesnt ask it, -d is not default! - for my $sourcefile (@sourcefiles){ - print "Deleting source file $sourcefile\n"; - unlink $sourcefile if $sourcefile; - } - for my $pkgfile (@pkgfiles){ - print "Deleting package $pkgfile\n"; - unlink $pkgfile if $pkgfile; - } -} - - -__END__ _______________________________________________ Frugalware-git mailing list [email protected] http://frugalware.org/mailman/listinfo/frugalware-git
