sets-portage>paludis

gistfile1.pl

#!/usr/bin/perl 
# (C)Kent Fredric 2008,2009
# Use Freely, No Warranty.
# All users may do with this code as maximally permitted by law.
use strict;
use warnings FATAL=>'all';

eval 'require MooseX::Declare; 1' or die q{ You need dev-perl/MooseX-Declare.  Check out the perl-experimental overlay };
eval 'require MooseX::Has::Sugar; 1' or die q{ You need dev-perl/MooseX-Has-Sugar.  Currently only available on github://kentfredric/perl-overlay };
eval 'require MooseX::Types::Moose; 1' or die q{ You need dev-perl/MooseX-Types. This is in mainline };
eval 'require CLASS; 1' or die q{ You need dev-perl/CLASS. Check out the perl-experimental overlay };
eval 'require Sub::Name; 1' or die q{ You need dev-perl/Sub-Name. This is in mainline };


### User Config
# Change these settings as needed.
# Yes, even the fix_set_name regex.

# These control what sets will be translated.
# This is the lowest level of complexity.
#
my %transitions = (
    'kde-live' => {
        source_repo  => '/var/paludis/repositories/kde-testing',
        setsdir      => '/sets',
        setglob      => '/*-live',
        outdir       => '/etc/paludis/sets/',
        fix_set_name => sub {
            $_ =~ s/\.//g;
            return $_;
        },
        fix_file_name => sub {
            my $self = shift;
            return $self->fix_set_name($_) . '.conf';
        },
        skip_set => sub {
            return 1 if $_ =~ /kdegames-.*/;
            return 0;
        },
        skip_pkg => sub {
            return 0;
        },
    },
    'kde-44' => {
        source_repo  => '/var/paludis/repositories/kde-testing',
        setsdir      => '/sets',
        setglob      => '/*-4.4',
        outdir       => '/etc/paludis/sets/',
        fix_set_name => sub {
            $_ =~ s/\.//g;
            return $_;
        },
        fix_file_name => sub {
            my $self = shift;
            return $self->fix_set_name($_) . '.conf';
        },
        skip_set => sub {
            return 1 if $_ =~ /kdegames-.*/;
            return 0;
        },
        skip_pkg => sub {
            return 0;
        },
    },
);

END {
# This governs how the translation 
# Works, and the order the parser scans rows.
# Medium Complexity
#
    my @translation_table = ();

    push @translation_table,
      Translation->new(
        name       => 'comment',
        matcher    => qr{^([^#]*)#(.*$)},
        colour     => 33,
        trace      => sub { shift;  "comment # $_[2]" },
        skip       => sub { 1; },
        stops      => 0,
        output     => sub { shift; $_[1] },
		format     => sub { '' }
      );

    push @translation_table,
      Translation->new(
        name    => 'set',
        matcher => qr{^@(.*$)},
        colour  => 34,
        trace   => sub { shift; "set # $_[1]" },
        skip    => sub { shift; $_[0]->skip_set( $_[1] ) },
        format  => sub { shift; '* ' . $_[0]->fix_set_name( $_[1] ) }
      );

    push @translation_table,
      Translation->new(
        name    => 'slot',
        matcher => qr{^(.+:.+)$},
        colour  => 35,
        trace   => sub { shift; "slot # $_[1] " },
        skip    => sub { shift; $_[0]->skip_pkg( $_[1] ) },
        format  => sub { shift; '?: ' . $_[0]->fix_pkg_name( $_[1] ) },
      );

    push @translation_table,
      Translation->new(
        name    => 'package',
        matcher => qr{^(.+)$},
        colour  => 36,
        trace   => sub { shift; "package # $_[1] " },
        skip    => sub { shift; $_[0]->skip_pkg( $_[1] ) },
        format  => sub { shift; '? '. $_[0]->fix_pkg_name( $_[1] ) },
      );

# THis is where it actually kicks in.
    for my $config ( keys %transitions ) {
        Translator->new( %{ $transitions{$config} },
            translations => \@translation_table, )->process;
    }

}
## End Config.


# Here down, High Complexity.

use MooseX::Declare;

class FileTranslate { 
	use MooseX::Has::Sugar 0.0300;
	use MooseX::Types::Moose qw( :all );
	use CLASS;

	has source_file => ( isa => Str, rw, required, );
	has target_file => ( isa => Str, rw, required, );
	has translator  => ( isa => 'Translator', rw, required );
	has source_fh   => ( isa => FileHandle, rw, lazy, default => method { 
		if ( open my $fh , '<', $self->source_file ){ 
			return $fh;
		}
        warn "Cant Open \e[32m`" . $self->source_file . "' for input \e[0m : $^E ";
	});
	has target_fh   => ( isa => FileHandle, rw, lazy, default => method { 
		if ( open my $fh , '>', $self->target_file ){ 
			return $fh;
		}
        warn "Cant Open \e[32m`" . $self->target_file . "' for output \e[0m : $^E ";
	});
	method handles {
		return ($self->source_fh, $self->target_fh);
	}
	method process_line( Str $line ){
		use Data::Dumper qw( Dumper );
		$Data::Dumper::Terse=1;
		$Data::Dumper::Indent=1;
		$Data::Dumper::Quotekeys=0;
		my $emit = '';
		chomp($line);
		for my $translation ( @{ $self->translator->translations } ){
			if( $translation->matches( $line ) ){
				my ( @param );
				@param = $translation->parse( $line  );
				my $state = { 
					param => \@param,
					emit  => scalar $translation->format( $self->translator, @param ),
					line  => $line,
					outline => scalar $translation->output( $self->translator, @param ),
					name  => scalar $translation->name, 
					trace => scalar  $translation->trace( $self->translator, @param ),
					stops => scalar $translation->stops,
				};
				if( $translation->skip($self->translator, @param) ){
					print "\e[" . $translation->colour .'m'. $state->{trace} . ' @ ' . $. . '-' x 40 . "---[ SKIPPED ]--\e[0m\n";
				} else {
					print "\e[" . $translation->colour .'m'. $state->{trace} . ' @ ' . $. . "\e[0m\n";
					$emit .= $state->{emit};
				}
				$line = $state->{outline};
				return $emit ."\n" if $translation->stops;
			}
		}
	}

	method process {
		my ( $ifh, $ofh ) = $self->handles;
    	while ( my $line = <$ifh> ) {
		 	print $ofh $self->process_line( $line );
    	}
	}
}

class Translator { 
	use MooseX::Has::Sugar 0.0300;
	use MooseX::Types::Moose qw( :all );
	use CLASS;
	use Sub::Name;

	has source_repo  => ( isa => Str, rw, required , );
	has setsdir      => ( isa => Str, rw, required , );
	has setglob      => ( isa => Str, rw, required , );
	has outdir       => ( isa => Str, rw, required , );
	has _fix_set_name  => ( isa => CodeRef, rw, lazy_build, init_arg => 'fix_set_name'  );
	has _fix_file_name => ( isa => CodeRef, rw, lazy_build, init_arg => 'fix_file_name' );
	has _fix_pkg_name => ( isa => CodeRef, rw, lazy_build, init_arg => 'fix_pkg_name' );
	has _skip_set      => ( isa => CodeRef, rw, lazy_build, init_arg => 'skip_set'      );
	has _skip_pkg      => ( isa => CodeRef, rw, lazy_build, init_arg => 'skip_pkg'      );
	has translations   => ( isa => ArrayRef[ 'Translation' ], rw, lazy_build );

	method default_fix_pkg_name { return $_ } 
	method default_fix_set_name { $_ =~ s/\.//g; return $_ } 
	method default_fix_file_name { $self->fix_set_name( $_ ) . '.conf'  }
	method default_skip_set { return 0; } 
	method default_skip_pkg { return 0; }

	my (@magic) = qw( fix_set_name fix_pkg_name fix_file_name skip_set skip_pkg );
	for my $c (@magic){
		my $attr = $CLASS->meta->get_attribute('_'.$c);
		my $default = $CLASS->meta->find_method_by_name('default_' . $c )->body;

		$CLASS->meta->add_method($c, subname("$c <generated>" , sub{
			my ( $self, @args ) = @_;
			my $sub = $attr->get_value( $self );
			$sub = subname("_$c <attribute coderef>", $sub );
			local $_ ;
			$_ = $args[0];
			return $self->$sub( @args );
		}));

		$CLASS->meta->add_method('_build__'.$c, sub { 
	#		print "Generated default for $c on object";
			return $default;
		});
	}
	method BUILD {
		for (@magic){
			my $c = $self->can('_'.$_);
			$self->$c();
		}
	}

	method _build_dependencies { return [] }

    method config_to_files {
        return glob (  $self->source_repo . $self->setsdir . $self->setglob );
    }

	method for_each ( CodeRef $call ) {
		for my $file ( $self->config_to_files ) {
			$self->$call( $file );
		}
	}

	method out_file ( Any $file ){
		my $basename = $file;
        $basename =~ s{^.*/}{};
        my $v = ( $self->outdir . '/' . $self->fix_file_name( $basename ) );
		return $v;
	}

	method process_file ( $file ) { 
		print "Processing $file\n";
		my $ft = FileTranslate->new( 
			source_file => $file, 
			target_file => $self->out_file( $file ),
			translator  => $self,
		);
		$ft->process;
		print "Generated ". $ft->target_file . "\n";
	}

	method process {
		$self->for_each( $self->can('process_file') );
	}
}
class Translation {
	use MooseX::Has::Sugar 0.0300;
	use MooseX::Types::Moose qw( :all );
	use CLASS;
	use Sub::Name;

    has name    => ( isa => Str,       rw, required,);
    has matcher => ( isa => RegexpRef, rw, required, );
    has colour  => ( isa => Int,       rw, default  => 30, );
    has stops   => ( isa => Bool,      rw, default  => 1, );
    has _trace  => ( isa => CodeRef,   rw, init_arg => 'trace',  lazy_build,  );
	has _skip   => ( isa => CodeRef,   rw, init_arg => 'skip',   lazy_build,  );
	has _format => ( isa => CodeRef,   rw, init_arg => 'format', lazy_build,  );
	has _output => ( isa => CodeRef,   rw, init_arg => 'output', lazy_build,  );

	method BUILD {
		$self->_output;
		$self->_format;
		$self->_skip;
		$self->_trace;
	}
	method default_trace ( Any @args ) { $self->name }
	method default_skip  ( Any @args ) { 0 }
	method default_format  ( Any @args ){ '' }
	method default_output  ( Any @args ){ '' }
	
	for my $c (qw( trace skip format output )){
		my $cc = $c;
		my $attr = $CLASS->meta->get_attribute('_'.$c);
		my $default = $CLASS->meta->find_method_by_name('default_'.$c)->body;
		$CLASS->meta->add_method($cc, sub {
			my ($self,@args) = @_;
			my $sub = $attr->get_value( $self );
			$sub = subname( "$cc <attribute coderef>", $sub );
#			print "Call to $cc on object " . $self->name . "\n";
#			use Data::Dumper;
#			print Dumper( \@args );
			return $self->$sub( @args );
		});
		$CLASS->meta->add_method('_build__'.$c, sub { 
#			print "Generated default for $c on object " . shift->name ."\n";
			return $default;
		});
	}

	method matches ( Str $content ){
		return scalar $self->parse( $content );
	}
    method parse ( Str $content ) {
        my @capture = ( $content =~ $self->matcher );
        return @capture;
    }

    method to_s ( Any @args ){
        "\e" . $self->colour . " " . $self->_trace(@args);
    }
}