Arch-0.5.2/0000755000076400007640000000000011345211110011040 5ustar migomigoArch-0.5.2/perllib/0000755000076400007640000000000011345211110012471 5ustar migomigoArch-0.5.2/perllib/Arch.pm0000644000076400007640000000451510326554655013737 0ustar migomigo# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch; use vars qw($VERSION); $VERSION = '0.5.2'; $VERSION = eval $VERSION; 1; __END__ =head1 NAME Arch - GNU Arch Perl library =head1 SYNOPSIS use Arch 0.5.2; # perldoc Arch # axp man Arch # example: produce ChangeLog for the current project use Arch::Tree; foreach my $log (Arch::Tree->new->get_logs) { print "-" x 80, "\n"; print $log->standard_date, "\n"; print $log->summary, "\n\n"; print $log->body; } =head1 DESCRIPTION The Arch-Perl library allows Perl developers to create GNU Arch front-ends in an object oriented fashion. GNU Arch is a decentralized, changeset-oriented revision control system. Currently, a pragmatic high-level interface is built around tla or baz. This functionality was initially developed for ArchZoom project, and was highly enhanced to serve AXP and ArchWay projects as well. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =head1 SEE ALSO For more information, see L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L. L, L. =cut Arch-0.5.2/perllib/Arch/0000755000076400007640000000000011345211110013346 5ustar migomigoArch-0.5.2/perllib/Arch/Test/0000755000076400007640000000000011345211110014265 5ustar migomigoArch-0.5.2/perllib/Arch/Test/Archive.pm0000644000076400007640000001064410227341010016212 0ustar migomigo# Arch Perl library, Copyright (C) 2005 Enno Cramer # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Test::Archive; use Arch::Backend qw(has_archive_setup_cmd); sub new ($$$) { my $class = shift; my ($fw, $name) = @_; my $self = { name => $name, framework => $fw, structure => { } }; bless $self, $class; return $self; } sub name ($) { my $self = shift; return $self->{name}; } sub framework ($) { my $self = shift; return $self->{framework}; } sub run_tla ($@) { my $self = shift; $self->framework->run_tla(@_); } # name generation sub gen_id ($;@) { my $self = shift; my @tree = @_; die "gen_id is private" if caller ne __PACKAGE__; my $ref = $self->{structure}; foreach my $key (@tree) { $ref->{$key} = { '=count' => 0 } unless exists $ref->{$key}; $ref = $ref->{$key}; } return $ref->{'=count'}++; } sub split_arch_name ($$$) { my $self = shift; my $name = shift || ''; my $maxlen = shift || 3; if ($name =~ s,^(.+)/,,) { die "Prefix from different archive: $1\n" if $1 ne $self->name; } my @parts = $name ? split /--/, $name : (); die "Arch name $name too long\n" if @parts > $maxlen; return @parts; } sub join_arch_name ($@) { my $self = shift; return join '--', @_; } sub make_category ($;$) { my $self = shift; my @prefix = @_; unshift @prefix, $self->split_arch_name(shift @prefix, 1); if (@prefix < 1) { push @prefix, "category-" . $self->gen_id(@prefix); } my $name = $self->join_arch_name(@prefix); $self->run_tla('archive-setup', '-A', $self->name, $name) if has_archive_setup_cmd(); return $self->name . "/$name"; } sub make_branch ($;$$) { my $self = shift; my @prefix = @_; unshift @prefix, $self->split_arch_name(shift @prefix, 2); if (@prefix < 2) { @prefix = $self->split_arch_name($self->make_category(@prefix), 1) if @prefix < 1; push @prefix, 'branch-' . $self->gen_id(@prefix); } my $name = $self->join_arch_name(@prefix); $self->run_tla('archive-setup', '-A', $self->name, $name) if has_archive_setup_cmd(); return $self->name . "/$name"; } sub make_version ($;$$$) { my $self = shift; my @prefix = @_; unshift @prefix, $self->split_arch_name(shift @prefix, 3); if (@prefix < 3) { @prefix = $self->split_arch_name($self->make_branch(@prefix), 2) if @prefix < 2; push @prefix, $self->gen_id(@prefix); } my $name = $self->join_arch_name(@prefix); $self->run_tla('archive-setup', '-A', $self->name, $name) if has_archive_setup_cmd(); return $self->name . "/$name"; } 1; __END__ =head1 NAME Arch::Test::Archive - A test framework for Arch-Perl =head1 SYNOPSIS use Arch::Test::Framework; my $fw = Arch::Test::Framework->new; my $archive = $fw->make_archive; my $version1 = $archive->make_version(); my $version2 = $archive->make_version($branch); =head1 DESCRIPTION Arch::Test::Archive provides methods to quickly build and modify Arch archives. =head1 METHODS B, B, B, B B, B, B, =over 4 =item B I I Create a new Arch::Test::Archive instance for archive I. This method should not be called directly. =item B Returns the archive name. =item B Returns the associated Arch::Test::Framework reference. =item B I<@args> Run tla with the specified arguments. =item B [I] =item B [I [I]] =item B [I [I [I]]] Create a new category, branch or version. A unique name for unspecified parts is generated. The fully qualified name is returned. =back =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =cut Arch-0.5.2/perllib/Arch/Test/Tree.pm0000644000076400007640000001575110227335611015546 0ustar migomigo# Arch Perl library, Copyright (C) 2005 Enno Cramer # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Test::Tree; use Arch::TempFiles qw(); use Arch::Util qw(); use POSIX qw(getcwd); sub new { my $class = shift; my $fw = shift; my $path = shift; my $self = { root => $path, framework => $fw, files => { } }; bless $self, $class; return $self; } sub root ($) { my $self = shift; return $self->{root}; } sub framework ($) { my $self = shift; return $self->{framework}; } sub run_tla ($@) { my $self = shift; my $cwd = getcwd; chdir($self->root); my @ret = $self->framework->run_tla(@_); chdir($cwd); return wantarray ? @ret : $ret[0]; } sub run_cmd ($@) { my $self = shift; my $cwd = getcwd; chdir($self->root); my @ret = Arch::Util::run_cmd(@_); chdir($cwd); die "run_cmd(".join(' ', @_).") failed: $?\n" if $?; return wantarray ? @ret : $ret[0]; } sub gen_id ($$) { my $self = shift; my $parent = shift; $self->{files}->{$parent} = 0 unless exists $self->{files}->{$parent}; return $self->{files}->{$parent}++; } sub add_file ($;$$$) { my $self = shift; my $dir = shift || '.'; my $name = shift || 'file-' . $self->gen_id($dir); my $cont = shift || "Content for $name.\n"; my $fname = "$dir/$name"; my $path = $self->root . "/$fname"; Arch::Util::save_file($path, $cont); $self->run_tla('add-id', $fname); return $fname; } sub add_dir ($;$$) { my $self = shift; my $dir = shift || '.'; my $name = shift || 'dir-' . $self->gen_id($dir); my $fname = "$dir/$name"; my $path = $self->root . "/$fname"; mkdir($path) || die "mkdir($path) failed: $!\n"; $self->run_tla('add-id', $fname); return $fname; } sub add_link ($;$$$) { my $self = shift; my $dir = shift || '.'; my $name = shift || 'file-' . $self->gen_id($dir); my $cont = shift || "Link-target-for-$name"; my $fname = "$dir/$name"; $self->run_cmd('/bin/ln', '-s', $cont, $fname); $self->run_tla('add-id', $fname); return $fname; } sub modify_file($$;$) { my $self = shift; my $file = shift; my $content = shift || Arch::Util::load_file($self->root . "/$file") . "Has been modified.\n"; Arch::Util::save_file($self->root . "/$file", $content); } sub rename_file ($$$) { my $self = shift; my ($old, $new) = @_; my $ret = $new; if (-d $self->root . "/$new") { (my $name = $old) =~ s,(.+/),,; $ret .= "/$name"; } $ret = './' . $ret unless $ret =~ /^\.\//; $self->run_tla('mv', $old, $new); return $ret; } sub rename_dir ($$$) { my $self = shift; my ($old, $new) = @_; my $ret = $new; if (-d $self->root . "/$new") { (my $name = $old) =~ s,(.+/),,; $ret .= "/$name"; } $ret = './' . $ret unless $ret =~ /^\.\//; $self->run_cmd('mv', $old, $new); return $ret; } sub remove_file ($$) { my $self = shift; my $file = shift; $self->run_tla('rm', $file); } sub remove_dir ($$) { my $self = shift; my $dir = shift; Arch::Util::remove_dir($self->root . "/$dir"); } sub inventory ($;$) { my $self = shift; my $flags = shift || '-Bs'; return $self->run_tla('inventory', $flags); } # this fails in baz-1.2 (that is broken), but not in baz-1.1 and baz-1.3 sub import ($;$$) { my $self = shift; return unless ref($self); # this is not for "use" my @opts = ('-d', $self->root); push @opts, ('-s', shift) if @_; push @opts, ('-L', shift) if @_; $self->run_tla('import', @opts); } sub commit ($;$$) { my $self = shift; my @opts = ('-d', $self->root); push @opts, ('-s', shift) if @_; push @opts, ('-L', shift) if @_; $self->run_tla('commit', @opts); } 1; __END__ =head1 NAME Arch::Test::Tree - A test framework for Arch-Perl =head1 SYNOPSIS use Arch::Test::Framework; my $fw = Arch::Test::Framework->new; my $tree = $fw->make_tree($dir, $version); my $dir = $tree->add_dir; $tree->add_file($dir); $tree->import; =head1 DESCRIPTION Arch::Test::Tree provides methods to quickly build and modify Arch project trees within the Arch::Test framework. =head1 METHODS B, B, B, B, B, B, B, B, B, B, B, B, B, B, B. =over 4 =item B [I] [I] Create a new Arch::Test::Tree instance for I. This method should not be called directly. =item B Returns the project trees root directory. =item B Returns the associated Arch::Test::Framework reference. =item B I<@args> Run C> from the tree root. =item B [I [I [I]]] Add a new file I in directory I. Fill file with I. I defaults to the project root (C<.>). If I is not specified, a unique filename is generated. A default content is generated if none is given. =item B [I [I]] Add a new directory under I, or C<.> if I is not specified. If I is not given, a unique name is generated. =item B [I [I [I]]] Add a new symbolic link under I, or C<.> if I is not specified. If I is not given, a unique name is generated. If I is omitted, a (probably) non-existing target is generated. =item B I [I] Change Is content to I, or append C if new content is omitted. =item B I I Rename file I to I. Returns I. =item B I I Rename directory I to I. Returns I. =item B I Delete I and its associated arch id. =item B I Recursively delete I and its content. =item B [I] Returns the inventory as generated by running C>. I default to C<-Bs> if not specified. =item B [I [I]] Create a C revision from tree using the summary line I and I as log text. If I contains a log file, I and I can be omitted. =item B [I [I]] Commit a C revision from tree using the summary line I and I as log text. If I contains a log file, I and I can be omitted. =back =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =cut Arch-0.5.2/perllib/Arch/Test/Cases.pm0000644000076400007640000000700110222062444015666 0ustar migomigo# Arch Perl library, Copyright (C) 2005 Enno Cramer # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Test::Cases; use Arch::Test::Framework; use Arch::Test::Tree; sub generate_empty_tree ($$;$) { my $fw = shift; return $fw->make_tree(@_); } sub generate_trivial_tree ($$;$) { my $tree = &generate_empty_tree(@_); foreach my $f (qw(README INSTALL COPYING)) { $tree->add_file('.', $f); } return $tree; } sub generate_simple_tree ($$;$) { my $tree = &generate_trivial_tree(@_); my $inc = $tree->add_dir('.', 'include'); my $src = $tree->add_dir('.', 'src'); my $bld = $tree->add_dir('.', 'build'); foreach my $f (qw(io.h logic.h)) { $tree->add_file($inc, $f); } foreach my $f (qw(io.c logic.c main.c)) { $tree->add_file($src, $f); } $tree->add_file('.', 'Makefile'); return $tree; } sub generate_complex_tree ($$;$) { my $tree = &generate_trivial_tree(@_); my $version = join('--', reverse split(/\//, $_[1])); my $inc = $tree->add_dir('.', 'include'); my $src = $tree->add_dir('.', 'src'); my $dat = $tree->add_dir('.', 'data'); # text source files foreach my $d (qw(base util io mem)) { my $inc_sub = $tree->add_dir($inc, $d); my $src_sub = $tree->add_dir($src, $d); for (1..10) { $tree->add_file($inc_sub); $tree->add_file($src_sub); } } # binary files for (1..3) { $tree->add_file($dat, undef, pack('CCCC', 1, 2, 3, 4)); } # symlink $tree->add_link('.', 'LICENSE', 'COPYING'); # clutter $tree->add_dir('.', ',,undo-1'); $tree->add_file('.', "++log.$version~"); $tree->add_file('.', '+notes'); $tree->add_file('.', 'README~'); return $tree; } 1; __END__ =head1 NAME Arch::Test::Cases - A test framework for Arch-Perl =head1 SYNOPSIS use Arch::Test::Framework; my $fw = Arch::Test::Framework->new; my $ver = $fw->make_version; my $tree = Arch::Test::Cases::generate_complex_tree($fw, $ver); =head1 DESCRIPTION Arch::Test::Tree provides methods to quickly build and modify Arch project trees within the Arch::Test framework. =head1 METHODS B, B, B, B. =over 4 =item B I I [I] Create a new project tree for I. Equivalent to $framework->make_tree($version, $name); =item B I I [I] Create a new project tree for I with basic files. =item B I I [I] Create a new project tree for I with basic and source files. =item B I I [I] Create a new project tree for I with basic and source files and a bit of clutter. =back =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =cut Arch-0.5.2/perllib/Arch/Test/Framework.pm0000644000076400007640000001241510222062444016572 0ustar migomigo# Arch Perl library, Copyright (C) 2005 Enno Cramer # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Test::Framework; use Arch::Test::Archive; use Arch::Test::Tree; use Arch::Test::Cases; use Arch::TempFiles qw(); use Arch::Util qw(); sub new ($;%) { my $class = shift; my %args = @_; my $home = $args{home} || Arch::TempFiles::temp_dir('arch-test'); my $self = { arch_uid => '', home => $home, library => $args{library} || "$home/library", archives => $args{archives} || "$home/archives", trees => $args{trees} || "$home/trees", ids => {}, }; die "Cannot access directory $self->{home}\n" unless -d $home && -w $home; bless $self, $class; # setup home directory foreach my $dir (( $self->archives_dir, $self->library_dir, $self->trees_dir )) { mkdir $dir unless -d $dir; } unless (-d "$self->{home}/.arch-params") { $self->run_tla( 'my-id', $args{userid} || 'Arch Perl Test ' ); $self->run_tla( 'my-revision-library', $self->library_dir ); $self->run_tla( 'library-config', '--sparse', '--non-greedy', $self->library_dir ); } $self->{arch_uid} = $self->run_tla('my-id', '--uid'); return $self; } # field access sub arch_uid ($) { my $self = shift; return $self->{arch_uid}; } sub home_dir ($) { my $self = shift; return $self->{home}; } sub library_dir ($) { my $self = shift; return $self->{library}; } sub archives_dir ($) { my $self = shift; return $self->{archives}; } sub trees_dir ($) { my $self = shift; return $self->{trees}; } # run with correct environment sub run_tla ($@) { my $self = shift; local $ENV{HOME} = $self->home_dir; my @lines = Arch::Util::run_tla(@_); die "run_tla(".join(' ', @_).") failed: $?\n" if $?; return wantarray ? @lines : $lines[0]; } sub gen_id ($$) { my $self = shift; my $section = shift; $self->{ids}->{$section} = 0 unless exists $self->{ids}->{$section}; return $self->{ids}->{$section}++; } sub make_archive ($;$) { my $self = shift; my $name = shift || $self->arch_uid . '--archive-' . $self->gen_id('archives'); my $path = $self->archives_dir . "/$name"; $self->run_tla('make-archive', $name, $path); return Arch::Test::Archive->new($self, $name); } sub make_tree ($$;$) { my $self = shift; my $version = shift; my $tree = shift || 'tree-' . $self->gen_id('trees'); my $path = $self->trees_dir . "/$tree"; mkdir($path) || die "mkdir($path) failed: $!\n"; $self->run_tla('init-tree', '-d', $path, $version); return Arch::Test::Tree->new($self, $path); } 1; __END__ =head1 NAME Arch::Test::Framework - A test framework for Arch-Perl =head1 SYNOPSIS use Arch::Test::Framework; my $fw = Arch::Test::Framework->new; my $archive = $fw->make_archive; my $version = $archive->make_version(); my $tree = $fw->make_tree($version); # # do something with $tree # $tree->import('initial import'); =head1 DESCRIPTION Arch::Test::Framework is a framework to quickly generate testing data (archives, versions, trees, changesets, etc) for arch-perl unit tests. =head1 METHODS B, B, B, B, B, B, B, B, B, B, B. =over 4 =item B [I<%args>] Create a new arch-perl test environment. Valid keys for I<%args> are I to specify an existing test environment to reuse, I to specify a different revision library path, I to specify a different archives directory, and I to specify a differente project tree directory. The default values are C<$home/library>, C<$home/archives>, and C<$home/trees> respectively. A different arch user id can be selected with the I key, the default is Carch-perl-test@example.comE>. =item B =item B =item B =item B =item B These methods return the environment parameters as initialized by B. =item B [I] Create a new archive in the archives directory. If I is not specified a unique name is generated. The archive name is returned. Returns an L reference for the archive. =item B I [I] Create and initialize (C) a new project tree for I. I I is not specified, a unique identifier will be generated. Returns an L reference for the project tree. =back =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =cut Arch-0.5.2/perllib/Arch/SharedCache.pm0000644000076400007640000001071110313056325016047 0ustar migomigo# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::SharedCache; use base 'Arch::SharedIndex'; use Arch::Util qw(save_file load_file); sub new ($%) { my $class = shift; my %init = @_; my $dir = $init{dir} or die "No cache directory given\n"; unless (-d $dir) { mkdir($dir, 0777) or die "Can't create cache directory $dir: $!\n"; } -d $dir or die "No cache directory ($dir)\n"; my $index_file = $init{index_file} || $init{file} || '.index'; $index_file = "$dir/$index_file" unless $index_file =~ m!^\.?/!; my $self = $class->SUPER::new( # default to a more readable serialization output perl_data_indent => 1, perl_data_pair => " => ", %init, file => $index_file, ); $self->{dir} = $dir; $self->{generic_filenames} = $init{generic_filenames} || 0; return $self; } sub generate_unique_token ($) { my $self = shift; my $dir = $self->{dir}; my $prefix = time() . "-"; my $token = $prefix . "000000"; return $token unless -e "$dir/$token"; my $tries = 1000000; do { $token = $prefix . sprintf("%06d", rand(1000000)); } while -e "$dir/$token" && --$tries; die "Failed to acquire unused file name $dir/$prefix*\n" unless $tries; return $token; } sub file_name_by_token ($$) { my $self = shift; my $token = shift; $token =~ s!/!%!g; return "$self->{dir}/$token"; } sub delete_value ($$$) { my $self = shift; my ($key, $token) = @_; $token = $key if $token eq ""; my $file_name = $self->file_name_by_token($token); return unless -e $file_name; unlink($file_name) or warn "Can't unlink $file_name: $!\n"; } sub fetch_value ($$$) { my $self = shift; my ($key, $token) = @_; $token = $key if $token eq ""; my $file_name = $self->file_name_by_token($token); my $value = eval { load_file($file_name); }; warn $@ if $@; $self->decode_value(\$value); return $value; } sub store_value ($$$) { my $self = shift; my ($key, $token, $value) = @_; $token = $key if defined $token && $token eq ""; $token = $key if !defined $token && !$self->{generic_filenames}; $token = $self->generate_unique_token if !defined $token || $token eq ""; my $file_name = $self->file_name_by_token($token); $self->encode_value(\$value); eval { save_file($file_name, \$value); }; warn $@ if $@; $token = "" if $key eq $token; $token = undef if $@; return $token; } 1; __END__ =head1 NAME Arch::SharedCache - a synchronized data structure (map) for IPC =head1 SYNOPSIS use Arch::SharedCache; my $cache = Arch::SharedCache->new( dir => '/tmp/dir-listings', max_size => 100, expiration => 600, # 10 minutes ); sub ls_long { scalar `ls -l $_[0]` } my $user_dir = '/usr/share'; $cache->store($user_dir => ls_long($user_dir)); $cache->fetch_store(sub { ls_long($_[0]) }, qw(/tmp /bin /usr/share)); printf "Cached listing of $user_dir:\n%s", $cache->fetch($user_dir); $cache->delete($user_dir); # examine /tmp/dir-listings/ after running this script # see also synopsys of Arch::SharedIndex =head1 DESCRIPTION Arch::SharedCache provides an Arch::SharedIndex implementation using a single file per value. =head1 METHODS The following methods are available: B. Other methods are documented in L. =over 4 =item B I Create a new Arch::SharedCache object. I is a hash of options. =over 4 =item B The cache directory used to store data. Will be created if it doesn't exist. =item B Name of the index file for the cache. Defaults to C/.index>. =back =back =head1 BUGS Awaiting for your reports. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =head1 SEE ALSO For more information, see L. =cut Arch-0.5.2/perllib/Arch/Changeset.pm0000644000076400007640000002577310420244025015627 0ustar migomigo# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Changeset; use Arch::Util qw(load_file adjacent_revision); use Arch::Changes qw(:type); sub new ($$$) { my $class = shift; my $revision = shift || die "Arch::Changeset::new: no revision\n"; my $dir = shift || die "Arch::Changeset::new: no dir\n"; die "No changeset dir $dir for revision $revision\n" unless -d $dir; $dir =~ s!/$!!; my $self = { revision => $revision, dir => $dir, ancestor => undef, index_memo => {}, }; return bless $self, $class; } sub get_patch ($$;$$) { my $self = shift; my $filepath = shift; my $type = shift || 0; # 0 - unknown, 1 - modified (including metadata), 2 - new, 3 - removed $type = { MODIFY => 1, ADD => 2, DELETE => 3 }->{$type} || 0 unless $type =~ /^[0123]$/; my $full_file_asis = shift || 0; my $dir = $self->{dir}; my $change_type = ""; my $patch_file = "$dir/patches/$filepath.patch"; if (!-f $patch_file && $type == 0 || $type == 2) { $patch_file = "$dir/new-files-archive/$filepath"; $change_type = "new"; } if (!-f $patch_file && $type == 0 || $type == 3) { $patch_file = "$dir/removed-files-archive/$filepath"; $change_type = "removed"; } if (!-f $patch_file) { my $patch_content = "*** Currently unsupported patch type, possibly metadata or symlink change ***"; if ($type >= 2) { if (-l $patch_file) { $patch_content = readlink($patch_file); } else { die "No file $filepath patch in revision $self->{revision} changeset\n"; } } else { $patch_file = "/dev/null"; $change_type = "unsupported"; } return wantarray? ($patch_content, $patch_file, $change_type, 1): $patch_content; } my $patch_content = load_file($patch_file); # create fake patch from full file if needed my $asis = 0; if ($change_type ne "" && !($asis = $full_file_asis || -B $patch_file)) { my $has_end_line = $patch_content =~ /\n$/; my $num_lines = $patch_content =~ s/\n/\n/g; $num_lines += $has_end_line? 0: 1; my $file = $patch_file; $file =~ s!^\Q$dir\E/[^/]+/!!s; my ($file1, $file2, $line1, $line2, $prefix); if ($change_type eq "new") { $file1 = "/dev/null"; $file2 = $file; $line1 = "-0,0"; $line2 = "+1,$num_lines"; $prefix = "+"; } else { $file1 = $file; $file2 = "/dev/null"; $line1 = "-1,$num_lines"; $line2 = "+0,0"; $prefix = "-"; } chop $patch_content if $has_end_line; $patch_content =~ s/(^|\012)/$1$prefix/g; $patch_content .= "\n\\ No newline at end of file" unless $has_end_line; $patch_content = "--- $file1\n+++ $file2\n@@ $line1 $line2 @@\n$patch_content\n"; $change_type = ""; } $change_type ||= "patch"; return wantarray? ($patch_content, $patch_file, $change_type, $asis): $patch_content; } sub ancestor ($) { my $self = shift; my $ancestor = $self->{ancestor}; return $ancestor if $ancestor; if (-f "$self->{dir}/=ancestor") { $ancestor = load_file("$self->{dir}/=ancestor"); chomp($ancestor); } unless ($ancestor) { # just guess my $revision = $self->{revision}; $ancestor = adjacent_revision($revision, -1) || $revision; } return $self->{ancestor} = $ancestor; } sub get_index ($$) { my $self = shift; my $index = shift; return %{$self->{index_memo}->{$index}} if (exists $self->{index_memo}->{$index}); my $index_hash = {}; # TODO: add proper unescaping support foreach my $line (split /\n/, load_file($self->{dir} . '/' . $index)) { my ($path, $id) = split / /, $line, 2; $path =~ s,^\./,,; $index_hash->{$id} = $path; } $self->{index_memo}->{$index} = $index_hash; return %$index_hash; } sub get_changes ($) { my $self = shift; my %orig_dirs = $self->get_index('orig-dirs-index'); my %mod_dirs = $self->get_index('mod-dirs-index'); my %orig_files = $self->get_index('orig-files-index'); my %mod_files = $self->get_index('mod-files-index'); my $changes = Arch::Changes->new; # added dirs foreach my $id (keys %mod_dirs) { $changes->add(ADD, 1, $mod_dirs{$id}) unless (exists $orig_dirs{$id}); } # added files foreach my $id (keys %mod_files) { $changes->add(ADD, 0, $mod_files{$id}) unless (exists $orig_files{$id}); } # deleted dirs foreach my $id (keys %orig_dirs) { $changes->add(DELETE, 1, $orig_dirs{$id}) unless (exists $mod_dirs{$id}); } # deleted files foreach my $id (keys %orig_files) { $changes->add(DELETE, 0, $orig_files{$id}) unless (exists $mod_files{$id}); } # modified files foreach my $id (keys %mod_files) { $changes->add(MODIFY, 0, $mod_files{$id}) if (-f $self->{dir} . '/patches/' . $mod_files{$id} . '.patch'); } # dir metadata changes foreach my $id (keys %mod_dirs) { $changes->add(META_MODIFY, 1, $mod_dirs{$id}) if (-f $self->{dir} . '/patches/' . $mod_dirs{$id} . '/=dir-meta-mod'); } # file metadata changes foreach my $id (keys %mod_files) { $changes->add(META_MODIFY, 0, $mod_files{$id}) if (-f $self->{dir} . '/patches/' . $mod_files{$id} . '.meta-mod'); } my %ren_dirs; foreach (keys %orig_dirs) { $ren_dirs{$orig_dirs{$_}} = $mod_dirs{$_} if exists $mod_dirs{$_}; } # moved dirs foreach my $id (keys %orig_dirs) { if ( exists $orig_dirs{$id} && exists $mod_dirs{$id} && $orig_dirs{$id} ne $mod_dirs{$id} ) { (my $parent = $orig_dirs{$id}) =~ s!/?[^/]+$!!; my $tail = $&; my $found = 0; while (!$found && $parent) { $found = exists $ren_dirs{$parent} && (($ren_dirs{$parent} . $tail) eq $mod_dirs{$id}); $parent =~ s!/?[^/]+$!!; $tail = $& . $tail; } $changes->add(RENAME, 1, $orig_dirs{$id}, $mod_dirs{$id}) if !$found; } } # moved files foreach my $id (keys %orig_files) { if ( exists $orig_files{$id} && exists $mod_files{$id} && $orig_files{$id} ne $mod_files{$id} ) { (my $parent = $orig_files{$id}) =~ s!/?[^/]+$!!; my $tail = $&; my $found = 0; while (!$found && $parent) { last if $tail =~ m!^/\.arch-ids/!; $found = exists $ren_dirs{$parent} && (($ren_dirs{$parent} . $tail) eq $mod_files{$id}); $parent =~ s!/?[^/]+$!!; $tail = $& . $tail; } $changes->add(RENAME, 0, $orig_files{$id}, $mod_files{$id}) if !$found; } } return $changes; } sub get_all_diffs ($;%) { my $self = shift; my %params = @_; my @diffs = (); my $changes = $self->get_changes; foreach my $change ($changes->get) { next if $change->{is_dir}; my $type = $change->{type}; next unless $type eq MODIFY || !$params{no_new_files} && ($type eq ADD || $type eq DELETE); my $filepath = $change->{arguments}->[0]; next if $params{no_arch_files} && ($filepath =~ m!^{arch}/! || $filepath =~ m!(^|/).arch-ids/!); push @diffs, scalar $self->get_patch($filepath, $type) || "*** $filepath ***\n*** binary content not displayed ***"; } return wantarray? @diffs: \@diffs; } sub join_all_diffs ($;%) { my $self = shift; my $diffs = $self->get_all_diffs(@_); return join('', map { "\n$_\n" } @$diffs); } 1; __END__ =head1 NAME Arch::Changeset - class representing Arch changeset =head1 SYNOPSIS B objects may be created directly if you got a changeset directory: use Arch::Changeset; my $changeset = Arch::Changeset->new( 'migo@homemail.com--Perl-GPL/arch-perl--devel--0--patch-6', '/tmp/,,changeset-6', ); But often are created indirectly by other objects: use Arch::Session; $changeset = Arch::Session->new->get_revision_changeset( 'migo@homemail.com--Perl-GPL/arch-perl--devel--0--patch-6' ); use Arch::Library; $changeset = Arch::Library->new->get_revision_changeset( 'migo@homemail.com--Perl-GPL/arch-perl--devel--0--patch-6' ); print scalar $changeset->get_patch("perllib/Arch/Changeset.pm"); my $diff_file = ($changeset->get_patch("README", 1))[2]; print Arch::Util::load_file($diff_file); =head1 DESCRIPTION This class represents the changeset concept in Arch and provides some useful methods. =head1 METHODS The following methods are available: B, B, B, B, B, B, B. =over 4 =item B I I Construct the Arch::Changeset object associated with the given fully-qualified I and the existing directory I. =item B I =item B I I =item B I I I Return the patch (or otherwise content) of the given I in the changeset. I is integer: 0 (unknown, try to autodetect, this is the default), 1 (modified file, or metadata change), 2 (new file), 3 (removed file). The default behaviour is to create a fake diff against I for non-binary new and removed files; the I flag, if set to true, changes this behaviour and causes to return the content of such file as-is. Binary new and removed files are always returned as-is regardless of the flag. This flag is also ignored if I is 1. In the scalar content return the patch in diff(1) format (or the whole file content as described above). In the list content return 4 scalars: the patch, the file name on the disk containing this patch (or the whole file), the change type (that is "patch", "new" or "removed") and the as-is flag. The returned values that follow the first one (the patch/file content) share the order of the corresponding parameters; the parameters are more hints, while the returned values accurately describe the content. =item B I Returns the content of the index file I as an B => B hash. Valid Is are 'orig-dirs-index', 'orig-files-index', 'mod-dirs-index' and 'mod-files-index'. =item B Returns a list of changes in the changeset. =item B Returns all diffs in the changeset (array or arrayref). This includes changes of types I, I and I. =item B Returns concatenated output of all diffs in the changeset. =item B Return the ancestor of the changeset. If I<=ancestor> file is found (that is the case for library changesets) its content is returned, otherwise try to guess the ancestor of the revision using B. =back =head1 BUGS Awaiting for your reports. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). =head1 SEE ALSO For more information, see L, L, L, L. =cut Arch-0.5.2/perllib/Arch/RunLimit.pm0000644000076400007640000001043110256012205015452 0ustar migomigo# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::RunLimit; sub new ($%) { my $class = shift; my %init = @_; my $self = { limit => exists $init{limit}? $init{limit}: 5, timeout => exists $init{timeout}? $init{timeout}: 30 * 60, file => $init{file} || "/please/specify/run-limit-file", exceeded => undef, added => 0, }; $self->{exceeded} = 0 if $self->{limit} <= 0 || $self->{timeout} <= 0; bless $self, $class; return $self; } sub exceeded ($) { my $self = shift; return $self->{exceeded} if defined $self->{exceeded}; my ($hostname, $aliases, $addrtype, $length, $addr) = gethostent(); my $hostip = join('.', unpack("C$length", $addr)) if $length && $addr; $hostname ||= "unknown-host"; $hostip ||= "127.0.0.1"; die "Internal: Unexpected hostname ($hostname)\n" if $hostname =~ /\s/; die "Internal: Unexpected hostip ($hostip)\n" if $hostip =~ /\s/; $self->{host_id} = "$hostname=$hostip"; $self->{proc_able} = -d "/proc" && -d "/proc/$$", $self->{run_id} = "$^T $$ $self->{host_id}\n"; $self->_update_run_limit_file(1); return $self->{exceeded}; } sub _update_run_limit_file ($$) { my $self = shift; my $add_self = shift; return if $self->{exceeded}; my $file = $self->{file}; unless (-f $file) { open FH, ">$file" or die "Can't create run-limit file ($file)\n"; close FH; } open FH, "+<$file" or die "Can't open $file for updating: $!\n"; flock FH, 2; # wait for exclusive lock seek FH, 0, 0; # rewind to beginning my @content = ; # get current content print STDERR map { "run limit old: $_" } @content if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\2") ne "\0"; @content = grep { /^(\d+) (\d+) ([^\s]+)\n/ && ( $3 ne $self->{host_id} || time() - $1 < $self->{timeout} && (!$self->{proc_able} || -d "/proc/$2") ); } @content; if ($add_self) { if (@content >= $self->{limit}) { $self->{exceeded} = 1; } else { $self->{exceeded} = 0; $self->{added} = 1; push @content, $self->{run_id}; } } else { @content = grep { $_ ne $self->{run_id} } @content; } print STDERR map { "run limit new: $_" } @content if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\2") ne "\0"; seek FH, 0, 0; # rewind again truncate FH, 0; # empty the file print FH @content; # print the new content close FH; # release file } sub DESTROY ($) { my $self = shift; return unless $self->{added} && defined $self->{exceeded}; $self->_update_run_limit_file(0); } 1; __END__ =head1 NAME Arch::RunLimit - class to enforce a limit on the number of running processes =head1 SYNOPSIS use Arch::RunLimit my $limit = Arch::RunLimit->new(file => $limit_file); die "run-limit exceeded" if $limit->exceeded; =head1 DESCRIPTION Arch::RunLimit provides an easy way to enforce a limit on the number of concurrently running processes. =head1 METHODS The following methods are available: B, B. =over 4 =item B I<%opts> Create a new Arch::RunLimit object with the specified options: =over 4 =item B (mandatory) The file used to keep track of the number of processes. =item B The maximum number of concurrently running processes. Defaults to C<5>. =item B The timeout after which a process is assumed to be terminated in seconds. Defaults to C<1800> (30 minutes). =back =item B Return C<1> if the number of concurrently running processes has been exceeded, C<0> otherwise. =back =head1 BUGS Awaiting your reports. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =cut Arch-0.5.2/perllib/Arch/DiffParser.pm0000644000076400007640000001530510213675743015760 0ustar migomigo# Arch Perl library, Copyright (C) 2005 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::DiffParser; use Arch::Util qw(load_file); my $FILE1_PREFIX = '--- '; my $FILE2_PREFIX = '+++ '; my $HUNK_PREFIX = '@@ '; my $UNMOD_PREFIX = ' '; my $DEL_PREFIX = '-'; my $ADD_PREFIX = '+'; my $NOEOL_PREFIX = '\ No newline at end of file'; use constant FILE1_LINE => 1 << 1; use constant FILE2_LINE => 1 << 2; use constant HUNK_LINE => 1 << 3; use constant UNMOD_LINE => 1 << 4; use constant DEL_LINE => 1 << 5; use constant ADD_LINE => 1 << 6; use constant NOEOL_LINE => 1 << 7; sub new ($) { my $class = shift; my $self = { data => undef, }; return bless $self, $class; } sub parse ($$) { my $self = shift; my $content = $self->{content} = shift; die "Arch::DiffParser::parse: no diff content\n" unless $content; my @lines = $content =~ /(.*\n)/g; my $hunks = []; my $changes = []; $lines[0] =~ /^\Q$FILE1_PREFIX\E(.+?)(?:\t(.+))?$/o or die "Unexpected line 1: $lines[0]"; my ($filename1, $mtime1) = ($1, $2); $lines[1] =~ /^\Q$FILE2_PREFIX\E(.+?)(?:\t(.+))?$/o or die "Unexpected line 2: $lines[1]"; my ($filename2, $mtime2) = ($1, $2); my $last_line = FILE2_LINE; my $ln1 = 0; my $ln2 = 0; for (my $i = 2; $i < @lines; $i++) { if ($lines[$i] =~ /^\Q$HUNK_PREFIX\E-(\d+)(?:,(\d+))? \+(\d+)(?:,(\d+))?/o) { push @$hunks, [ $1, defined $2? $2: 1, $3, defined $4? $4: 1, $i ]; $last_line = HUNK_LINE; $ln1 = $1; $ln2 = $3; } elsif ($lines[$i] =~ /^\Q$DEL_PREFIX\E/o) { die if $last_line == ADD_LINE; push @$changes, [ $ln1, 0, $ln2, 0, $i ] unless $last_line == DEL_LINE; $changes->[-1][1]++; $last_line = DEL_LINE; $ln1++; } elsif ($lines[$i] =~ /^\Q$ADD_PREFIX\E/o) { push @$changes, [ $ln1, 0, $ln2, 0, $i ] unless $last_line & (DEL_LINE | ADD_LINE | NOEOL_LINE); $changes->[-1][3]++; $last_line = ADD_LINE; $ln2++; } elsif ($lines[$i] =~ /^\Q$UNMOD_PREFIX\E/o) { $last_line = UNMOD_LINE; $ln1++; $ln2++; } elsif ($lines[$i] =~ /^\Q$NOEOL_PREFIX\E/o) { $last_line = NOEOL_LINE; } else { die "Unrecognized diff line #" . ($i + 1) . ":\n$lines[$i]"; } } $self->{data} = { lines => \@lines, filename1 => $filename1, filename2 => $filename2, mtime1 => $mtime1, mtime2 => $mtime2, hunks => $hunks, changes => $changes, }; return $self; } sub parse_file ($$) { my $self = shift; my $file_name = shift; die "Arch::DiffParser::parse_file: no diff file name\n" unless $file_name; return $self->parse(load_file($file_name)); } sub diff_data ($) { my $self = shift; my $data = $self->{data}; die "Arch::DiffParser::info: no last diff info, perform parse first\n" unless $data; return $data; } sub content ($%) { my $self = shift; my %args = @_; return join("", @{$self->diff_data->{lines}}); } sub lines ($) { my $self = shift; return $self->diff_data->{lines}; } sub filename1 ($) { my $self = shift; return $self->diff_data->{filename1}; } sub filename2 ($) { my $self = shift; return $self->diff_data->{filename2}; } sub mtime1 ($) { my $self = shift; return $self->diff_data->{mtime1}; } sub mtime2 ($) { my $self = shift; return $self->diff_data->{mtime2}; } sub hunks ($) { my $self = shift; return $self->diff_data->{hunks}; } sub changes ($) { my $self = shift; return $self->diff_data->{changes}; } 1; __END__ =head1 NAME Arch::DiffParser - parse file's diff and perform some manipulations =head1 SYNOPSIS use Arch::DiffParser; my $dp = Arch::DiffParser->new; # usable for "annotate" functionality my $changes = $dp->parse_file("f.diff")->changes; $dp->parse($diff_content); $dp->parse("--- f1.c\t2005-02-26\n+++ f2.c\t2005-02-28\n..."); # prints "f1.c, f2.c" printf "%s, %s\n", $dp->filename1, $dp->filename2; # enclose lines in my $html = $dp->markup_content; =head1 DESCRIPTION This class provides a limited functionality to parse a single file diff in unified format. Multiple diffs may be parsed sequentially. The parsed data is stored for the last diff, and is replaced on the following parse. =head1 METHODS The following class methods are available: B, B, B, B, B, B, B, B, B, B, B. =over 4 =item B Construct the C instanse. =item B I Parse the I and store its parsed data. =item B I Like B, but read the I from I. =item B Return hashref containing certain parsed data. Die if called before any B methods. The keys are: "lines", "filename1", "filename2", "mtime1", "mtime2", "hunks", "changes". The value of "hunks" and "changes" is arrayref of arrayrefs with 5 elements: [ line-number-1, num-lines-1, line-number-2, num-lines-2, "lines"-index ]. A "hunk" describes a set of lines containing some combination of unmodified, deleted and added lines, a "change" describes an inter-hunk atom that only contains zero or more deleted lines and zero or more added lines. =item B =item B =item B =item B =item B =item B =item B These methods are just shortcuts for B->{I}. =item B [I<%args>] Return content of the last diff. I<%args> keys are "fileroot1" and "fileroot2"; if given, these will replace the subdirs "orig" and "mod" that arch usually uses in the filepaths. =item B [I<%args>] Like B, but every non-context line is enclosed into markup Espan class="patch_I"ElineE/spanE, where I is one of "orig" (filename1), "mod" (filename2), "line" (hunk linenums), "add" (added), del (deleted). Not implemented yet. =back =head1 BUGS No support for newlines in source file names yet. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). =head1 SEE ALSO For more information, see L, L. =cut Arch-0.5.2/perllib/Arch/RevisionBunches.pm0000644000076400007640000002537610206454646017051 0ustar migomigo# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::RevisionBunches; use Arch::Util qw(date2daysago); sub new ($%) { my $class = shift; my %args = @_; my $self = { bunched_revision_descs => [], new_revision_descs => [], bunches => [], versions => [], filepaths => [], bunch_size => 50, max_sumlen => undef, version => undef, final_revision => undef, final_filepath => undef, cb_remove_all_bunches => undef, cb_add_new_bunch => undef, }; bless $self, $class; return $self->init(%args); } sub init ($%) { my $self = shift; my %args = @_; while (my ($key, $value) = each %args) { unless (exists $self->{$key}) { warn "Arch::RevisionBunches: unknown key $key, ignoring\n"; next; } $self->{$key} = $value; } $self->{max_sumlen} = undef if $args{max_sumlen} && !($args{max_sumlen} =~ /^\d+$/ && $args{max_sumlen} > 5); return $self; } sub add_revision_descs ($$%) { my $self = shift; my $revision_descs = shift; my %args = @_; my $max_sumlen = $self->{max_sumlen}; foreach (@$revision_descs) { substr($_->{summary}, $max_sumlen - 3) = "..." if $max_sumlen && length($_->{summary}) > $max_sumlen; foreach my $arg (keys %args) { $_->{$arg} = $args{$arg}; } } push @{$self->{new_revision_descs}}, @$revision_descs; return $self; } sub get ($) { my $self = shift; $self->rebunch if @{$self->{new_revision_descs}}; return wantarray? @{$self->{bunches}}: $self->{bunches}; } sub _set_bunch_interval_data ($$;$) { my $self = shift; my $bunch = shift || die; my $start_index = shift || 0; my $nr = @{$bunch->{revision_descs}}; my $i = 1; my $idx2 = $nr > 1 ? -1 : undef; foreach my $idx (0, $idx2) { my $revision_desc = defined $idx && $bunch->{revision_descs}->[$idx]; $bunch->{"name$i"} = $revision_desc? $revision_desc->{name}: undef; my ($daysago, $time, $tz) = $revision_desc? date2daysago($revision_desc->{date}): (undef) x 3; $bunch->{"daysago$i"} = $daysago; $bunch->{"time$i"} = $time; $bunch->{"tz$i"} = $tz; $i++; } $bunch->{size} = $nr; my %creators = (); my $nm = 0; foreach my $revision_desc (@{$bunch->{revision_descs}}) { my $creator = $revision_desc->{creator} || ""; my $email = $revision_desc->{email} || ""; my $entry = $creators{$creator,$email} ||= [ $creator, $email, 0 ]; $entry->[2]++; $nm++ if $revision_desc->{is_merged}; } my $nc = $bunch->{num_creators} = scalar keys %creators; $bunch->{num_other_creators} = $nc? $nc - 1: 0; ($bunch->{main_creator}, $bunch->{main_email}) = @{ (sort { $b->[2] <=> $a->[2] } values %creators)[0] || [] }; $bunch->{creator} = $bunch->{main_creator} . ($nc == 1? "": " among $nc creators"); $bunch->{name} = $bunch->{name1}; $bunch->{date} = $bunch->{daysago1}; if ($bunch->{name2}) { $bunch->{name} .= " .. $bunch->{name2}"; $bunch->{date} .= " .. $bunch->{daysago2}"; } $bunch->{date} .= " days ago"; $bunch->{summary} = "$nr revision" . ($nr == 1? "": "s"); $bunch->{summary} .= ' (missing)' if $bunch->{is_missing} && $nm < $nr; $bunch->{summary} .= " ($nm merged)" if $nm > 0; $self->{cb_add_new_bunch}->($bunch, $start_index) if $self->{cb_add_new_bunch}; } sub _invalidate_bunches ($) { my $self = shift; $self->{cb_remove_all_bunches}->() if $self->{cb_remove_all_bunches}; unshift @{$self->{new_revision_descs}}, @{$self->{bunched_revision_descs}}; @{$self->{bunched_revision_descs}} = (); @{$self->{bunches}} = (); @{$self->{versions}} = (); @{$self->{filepaths}} = (); } sub rebunch ($;$) { my $self = shift; my $bunch_size = shift; my $change_size = !!$bunch_size; $bunch_size ||= $self->{bunch_size} || die "No bunch size given"; if ($change_size) { $self->{bunch_size} = $bunch_size; $self->_invalidate_bunches; } goto RETURN unless @{$self->{new_revision_descs}}; my $last_bunch = $self->{bunches}->[-1]; my $start_index = $last_bunch? @{$last_bunch->{revision_descs}}: 0; my $multi_version = !$self->{version}; while (my $rd = shift @{$self->{new_revision_descs}}) { my $version = $rd->{version}; my $is_missing = $rd->{is_missing}; my $has_is_missing = defined $is_missing; my $filepath = $rd->{filepath}; my $has_filepath = defined $filepath; my $is_bunch_property_changed = 0; if ($last_bunch && $multi_version && $last_bunch->{version} ne $version) { push @{$self->{versions}}, $version; $is_bunch_property_changed = 1; } if ($last_bunch && $has_is_missing && $last_bunch->{is_missing} ne $is_missing) { $is_bunch_property_changed = 1; } if (!$last_bunch || $has_filepath && $last_bunch->{filepath} ne $filepath) { push @{$self->{filepaths}}, $filepath; $is_bunch_property_changed = 1; } if ( !$last_bunch || $is_bunch_property_changed || @{$last_bunch->{revision_descs}} >= $bunch_size ) { $self->_set_bunch_interval_data($last_bunch, $start_index) if $last_bunch; $start_index = 0; $last_bunch = { revision_descs => [] }; $last_bunch->{version} = $version if $multi_version; $last_bunch->{filepath} = $filepath if $has_filepath; $last_bunch->{is_missing} = $is_missing if $has_is_missing; push @{$self->{bunches}}, $last_bunch; } push @{$last_bunch->{revision_descs}}, $rd; push @{$self->{bunched_revision_descs}}, $rd; } $self->_set_bunch_interval_data($last_bunch, $start_index) if $last_bunch; RETURN: return wantarray? @{$self->{bunches}}: $self->{bunches}; } sub clear ($) { my $self = shift; $self->_invalidate_bunches; @{$self->{new_revision_descs}} = @{$self->{bunched_revision_descs}} = (); return $self; } sub reverse_revision_descs ($) { my $self = shift; $self->_invalidate_bunches; @{$self->{new_revision_descs}} = reverse(@{$self->{new_revision_descs}}); return $self; } sub versions ($) { my $self = shift; return $self->{versions}; } sub filepaths ($) { my $self = shift; return $self->{filepaths}; } 1; __END__ =head1 NAME Arch::RevisionBunches - manage bunches of related revisions =head1 SYNOPSIS use Arch::RevisionBunches; use Arch::Tree; my $rb = Arch::RevisionBunches->new; my $tree = Arch::Tree->new(".", own_logs => 1); $rb->add_revision_descs($tree->get_history_revision_descs); $rb->rebunch(25); # the default is 50 foreach my $bunch ($rb->get) { print "$bunch->{version}\n"; print " $_->{name}\t$_->{summary}\n" foreach @{$bunch->{revision_descs}}; } foreach my $bunch ($rb->reverse_revision_descs->rebunch(30)) { print $bunch->{name1}; print " .. $bunch->{name2}" if $bunch->{name2}; print " ($bunch->{daysago1}"; print " .. $bunch->{daysago2}" if $bunch->{name2}; print " days ago)\n"; } =head1 DESCRIPTION This class helps front-ends to group revisions. Such grouping is essential when, for example, the version to be shown contains thousands of revisions. The front-end may decide to show expandable bunches of 100 revisions each. There is a support for revision descriptions (summary, date, creator, email, and in some cases associated the file name and/or the associated version). There is a constraint by convention, one bunch may only contain revisions of the same version, and the ones associated with the same file if applicable. It is possible to define an order of versions. It is possible to recreate bunches (rebunch) using a different number of revisions. The constraint defines the actual number of revisions in different bunches, it is not guaranteed to be the same. =head1 METHODS The following methods are available: B, B, B, B, B, B, B, B, B, B. =over 4 =item B [I<%args>] Construct Arch::RevisionBunches object. The I<%args> are passed to B method. =item B [I<%args>] The I<%args> keys may be I (to use as the default bunch size instead of 50), I (maximal summary length to keep including trailing ellipsis, must be greater than 5), I (if set, then all revisions are assumed to be of one version, otherwise multiple versions are assumed), I and I (the final revision and filepath for which the revision bunches are constructed). These last two I<%args> keys are not really used yet. =item B [I<%constant_fields>] Add revision descriptions that is arrayref of hashes. See other classes that return such revision descriptions. If the I<%constant_fields> is given, then add these to all revision descriptions (rarely needed). Return the object, this enables chaining of B or B method call. =item B [I] Group newly added revisions if no I is specified. Otherwise regroup all revisions using a given I. The default bunch size may be specified in the constructor. Return the same B does. =item B Return bunches that is arrayref in scalar context, array in list context. Each bunch is hashref with keys: revision_descs name1 daysago1 time1 tz1 name2 daysago2 time2 tz2 size num_creators num_other_creators main_creator main_email creator name date summary and optionally "version", "is_missing" and "filepath" if applicable. This method implicitly calls B with no parameter if new revision descriptions were added that are not bunched yet. =item B Clear all bunches and their revision descriptions. =item B Effectivelly empty all revision descriptions (both old and new) and readd them in the reverse order. Return the object, this enables chaining of B or B method call. =item B Return distinct versions participated in all bunches. Return empty arrayref if not applicable, i.e. if I is given in the constructor. =item B Return distinct filepaths participated in all bunches. Return empty arrayref if not applicable, i.e. if revision descriptions have no I. =back =head1 BUGS Waiting for your reports. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). =head1 SEE ALSO For more information, see L, L, L, L. =cut Arch-0.5.2/perllib/Arch/Run.pm0000644000076400007640000002275210321715443014473 0ustar migomigo# Arch Perl library, Copyright (C) 2004-2005 Mikhael Goikhman, Enno Cramer # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.006; use strict; package Arch::Run; use IO::Poll qw(POLLIN POLLOUT POLLERR); use POSIX qw(waitpid WNOHANG setsid); use constant RAW => 0; use constant LINES => 1; use constant ALL => 2; use vars qw(@ISA @EXPORT_OK @OBSERVERS %SUBS $DETACH_CONSOLE); use Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw( run_with_pipe run_async poll wait unobserve observe RAW LINES ALL ); BEGIN { $DETACH_CONSOLE = 0; } sub set_detach_console ($) { $DETACH_CONSOLE = shift; } sub run_with_pipe (@) { my $arg0 = shift || die "Missing command to run_with_pipe\n"; my @args = (split(/\s+/, $arg0), @_); pipe TO_PARENT_RDR, TO_PARENT_WRT; pipe TO_CHILD_RDR, TO_CHILD_WRT; my $pid = fork; die "Can't fork: $!\n" unless defined $pid; if ($pid) { close TO_PARENT_WRT; close TO_CHILD_RDR; return wantarray ? (\*TO_PARENT_RDR, \*TO_CHILD_WRT, $pid) : \*TO_PARENT_RDR; } else { close TO_PARENT_RDR; close TO_CHILD_WRT; close STDIN; # my perl won't compile this if i use # open STDIN, "<&", TO_CHILD_RDR # the same thing for STDOUT is accepted though, # the "<&" vs ">&" makes the difference open STDIN, "<&TO_CHILD_RDR"; close TO_CHILD_RDR; close STDOUT; open STDOUT, ">&TO_PARENT_WRT"; close TO_PARENT_WRT; setsid if $DETACH_CONSOLE; exec(@args); } } sub run_async (%) { my %args = @_; die "Missing command to run_async\n" unless exists $args{command}; my @args = ref $args{command} ? @{$args{command}} : $args{command}; my ($out, $in, $pid) = run_with_pipe(@args); _notify('cmd_start', $pid, @args); $SUBS{$pid} = { # in => $in, # not for now out => $out, mode => $args{mode}, data => $args{datacb}, exit => $args{exitcb}, accum => '', }; close($in); # no input for now return $pid; } sub get_output_handle ($) { my $key = shift; return $SUBS{$key}->{out}; } sub handle_output ($) { my $key = shift; my $rec = $SUBS{$key}; my $buffer; my $result = sysread $rec->{out}, $buffer, 4096; _notify('cmd_output_raw', $key, $buffer) if $result > 0; # handle output if ($result) { # raw mode if ($rec->{mode} eq RAW) { $rec->{data}->($buffer); # line mode } elsif ($rec->{mode} eq LINES) { $rec->{accum} .= $buffer; while ($rec->{accum} =~ s/^.*?(\015\012|\012|\015)//) { $rec->{data}->($&); } # bloody big block mode } else { $rec->{accum} .= $buffer; $rec->{data}->($rec->{accum}) if $result == 0; } # error and eof } else { $rec->{data}->($rec->{accum}) if length $rec->{accum}; my $pid = waitpid $key, 0; my $exitcode = $pid == $key ? $? : undef; _notify('cmd_exit', $exitcode); $rec->{exit}->($exitcode) if defined $rec->{exit}; delete $SUBS{$key}; } } sub poll (;$) { my $count = 0; # check for output my $poll = IO::Poll->new; foreach my $key (keys %SUBS) { $poll->mask($SUBS{$key}->{out}, POLLIN | POLLERR) unless $SUBS{$key}->{done}; } my $result = $poll->poll($_[0]); foreach my $key (keys %SUBS) { if ($poll->events($SUBS{$key}->{out})) { handle_output($key); ++$count; } } return $count; } sub wait ($) { my $pid = shift; my $ret; # overwrite callback to capture exit code if (exists $SUBS{$pid}) { my $old_cb = $SUBS{$pid}->{exit}; $SUBS{$pid}->{exit} = sub { $ret = shift; $old_cb->($ret) if defined $old_cb; }; # Poll until a) our target has exited or b) there are no more # file handles to poll for. while (exists $SUBS{$pid} && poll(undef)) {} } # returns undef if childs exit has already been handled return $ret; } sub killall (;$) { my $signal = shift || 'INT'; kill $signal, keys %SUBS; while (%SUBS && poll(undef)) {} } sub _notify (@) { die "no touching\n" if caller ne __PACKAGE__; my $method = shift; foreach my $observer (@OBSERVERS) { $observer->$method(@_) if $observer->can($method); } } sub unobserve ($) { my $observer = shift; @OBSERVERS = grep { $_ ne $observer } @OBSERVERS; } sub observe ($) { my $observer = shift; unobserve($observer); push @OBSERVERS, $observer; } 1; __END__ =head1 NAME Arch::Run - run subprocesses and capture output =head1 SYNOPSIS use Gtk2 -init; use Arch::Run qw(poll run_async LINES); my $window = Gtk2::Window->new; my $label = Gtk2::Label->new; my $pbar = Gtk2::ProgressBar->new; my $vbox = Gtk2::VBox->new; $vbox->add($label); $vbox->add($pbar); $window->add($vbox); $window->signal_connect(destroy => sub { Gtk2->main_quit; }); $window->set_default_size(200, 48); $window->show_all; sub set_str { $label->set_text($_[0]); } my $go = 1; # keep progress bar pulsing Glib::Timeout->add(100, sub { $pbar->pulse; poll(0); $go; }); run_async( command => [ 'du', '-hs', glob('/usr/share/*') ], mode => LINES, datacb => sub { chomp(my $str = $_[0]); set_str($str); }, exitcb => sub { $go = 0; set_str("exit code: $_[0]"); }, ); Gtk2->main; =head1 DESCRIPTION Arch::Run allows the user to run run subprocesses and capture their output in a single threaded environment without blocking the whole application. You can use either B to wait for and handle process output, or use B and B to integrate B with your applications main loop. =head1 METHODS The following functions are available: B, B, B, B, B, B, B, B, B. =over 4 =item B I<$command> =item B I<$executable> I<$argument> ... Fork and exec a program with STDIN and STDOUT connected to pipes. In scalar context returns the output handle, STDIN will be connected to /dev/null. In list context, returns the output and input handle. The programs standard error handle (STDERR) is left unchanged. =item B I<%args> Run a command asyncronously in the background. Returns the subprocesses pid. Valid keys for I<%args> are: =over 4 =item B => I<$command> =item B => [ I<$executable> I<$argument> ... ] Program and parameters. =item B => I<$accum_mode> Control how output data is accumulated and passed to B and B callbacks. I<$accum_mode> can be one of =over 4 =item B No accumulation. Pass output to B callback as it is received. =item B Accumulate output in lines. Pass every line separately to B callback. =item B Accumulate all data. Pass complete command output as one block to B callback. =back =item B => I<$data_callback> Codeblock or subroutine to be called when new output is available. Receives one parameter, the accumulated command output. =item B => I<$exit_callback> Codeblock or subroutine to be called when subprocess exits. Receives a single parameter, the commands exit code. (Or maybe not. We have to handle SIG{CHLD} then. But maybe we have to do so anyway.) =back =item B I<$pid> Returns the STDOUT handle of process $pid. You should never directly read from the returned handle. Use L or L to wait for output and call B to process the output. =item B I<$pid> Handle available output from process I<$pid>. B Call this method only if there really is output to be read. It will block otherwise. =item B I<$timeout> Check running subprocesses for available output and run callbacks as appropriate. Wait at most I<$timeout> seconds when no output is available. Returns the number of processes that had output available. =item B I<$pid> Wait for subprocess I<$pid> to terminate, repeatedly calling B. Returns the processes exit status or C if B has already been called after the processes exit. =item B [I<$signal>] Send signal I<$signal> (B if omitted) to all managed subprocesses, and wait until every subprocess to terminate. =item B I<$observer> Register an observer object that wishes to be notified of running subprocesses. I<$observer> should implement one or more of the following methods, depending on which event it wishes to receive. =over 4 =item B<-Ecmd_start> I<$pid> I<$executable> I<$argument> ... Called whenever a new subprocess has been started. Receives the subprocesses PID and the executed command line. =item B<-Ecmd_output_raw> I<$pid> I<$data> Called whenever a subprocess has generated output. Receives the subprocesses PID and a block of output data. B I<$data> is not preprocesses (e.g. split into lines). B receives data block as if B mode was used. =item B<-Ecmd_exit> I<$pid> I<$exitcode> Called whenever a subprocess exits. Receives the subprocesses PID and exit code. =back =item B I<$observer> Remove I<$observer> from observer list. =back =cut Arch-0.5.2/perllib/Arch/Tree.pm0000644000076400007640000007362510335774204014640 0ustar migomigo# Arch Perl library, Copyright (C) 2004-2005 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Tree; use Arch::Util qw(run_tla load_file _parse_revision_descs adjacent_revision); use Arch::Backend qw( is_baz has_tree_version_dir_opt has_tree_id_cmd has_set_tree_version_cmd has_file_diffs_cmd has_commit_version_arg has_commit_files_separator ); use Arch::Session; use Arch::Name; use Arch::Log; use Arch::Inventory; use Arch::Changes qw(:type); use Arch::Changeset; use Cwd; sub new ($;$%) { my $class = shift; my $dir = shift || "."; die "No tree dir $dir\n" unless -d $dir; my ($root) = run_tla("tree-root", $dir); die "No tree root for dir $dir\n" unless $root; my %init = @_; my $self = { dir => $root, own_logs => $init{own_logs}, hide_ids => $init{hide_ids}, cache_logs => $init{cache_logs}, }; bless $self, $class; $self->clear_cache; return $self; } sub root ($) { my $self = shift; return $self->{dir}; } sub get_id_tagging_method ($) { my $self = shift; ($self->{id_tagging_method}) = run_tla("id-tagging-method", "-d", $self->{dir}) unless $self->{id_tagging_method}; return $self->{id_tagging_method}; } sub get_version ($) { my $self = shift; return $self->{version} if $self->{version}; my @add_params = has_tree_version_dir_opt()? ("-d"): (); my ($version) = run_tla("tree-version", @add_params, $self->{dir}); return $self->{version} = $version; } sub get_revision ($) { my $self = shift; #return $self->{revision} if $self->{revision}; my $cmd = has_tree_id_cmd()? "tree-id": "logs -frd"; my ($revision) = run_tla($cmd, $self->{dir}); return $self->{revision} = $revision; } sub set_version ($$) { my $self = shift; my $version = shift; delete $self->{version}; my $cmd = has_set_tree_version_cmd()? "set-tree-version": "tree-version"; run_tla($cmd, "-d", $self->{dir}, $version); return $?; } sub get_log_versions ($) { my $self = shift; my @versions = run_tla("log-versions", "-d", $self->{dir}); return wantarray? @versions: \@versions; } sub add_log_version ($$) { my $self = shift; my $version = shift; run_tla("add-log-version", "-d", $self->{dir}, $version); return $?; } sub get_log_revisions ($;$) { my $self = shift; my $version = shift || $self->get_version; $version =~ s!-(SOURCE|MIRROR)/!/!; my @revisions = run_tla("logs", "-f", "-d", $self->{dir}, $version); return wantarray? @revisions: \@revisions; } sub get_log ($$) { my $self = shift; my $revision = shift || die; return $self->{cached_logs}->{$revision} if $self->{cached_logs}->{$revision}; my $message; if ($self->{own_logs}) { my $name = Arch::Name->new($revision); $name->is_valid('revision') or die "Invalid revision $revision\n"; my @n = $name->get; my $version_subdir = $n[2] ne ""? "$n[1]--$n[2]/$n[1]--$n[2]--$n[3]": "$n[1]/$n[1]--$n[3]"; my $subdir = "{arch}/$n[1]/$version_subdir/$n[0]/patch-log/$n[4]"; my $file = "$self->{dir}/$subdir"; $message = load_file($file) if -f $file; } else { $message = run_tla("cat-log", "-d", $self->{dir}, $revision); } return undef unless $message; my $log = Arch::Log->new($message, hide_ids => $self->{hide_ids}); $self->{cached_logs}->{$revision} = $log if $self->{cache_logs}; return $log; } sub get_logs ($;$) { my $self = shift; my $version = shift || $self->get_version; my $versions = ref($version) eq 'ARRAY'? $version: $version eq '*'? $self->get_log_versions: [ $version ]; my @logs = (); foreach (@$versions) { my $revisions = $self->get_log_revisions($_); foreach my $revision (@$revisions) { push @logs, $self->get_log($revision); } } return wantarray? @logs: \@logs; } sub get_log_revision_descs ($;$) { my $self = shift; my $version = shift; my $logs = $self->get_logs($version); my $revision_descs = []; foreach my $log (@$logs) { push @$revision_descs, $log->get_revision_desc; } return $revision_descs; } sub get_inventory ($) { my $self = shift; return Arch::Inventory->new($self->root); } # TODO: properly support file name escaping sub get_changes ($) { my $self = shift; my $is_baz = is_baz(); my @args = $is_baz ? qw(status) : qw(changes -d); my @lines = run_tla(@args, $self->{dir}); return undef if ($? >> 8) == 2; my $baz_1_1_conversion_table; $baz_1_1_conversion_table = { 'A ' => [ 'A ', 'A/' ], 'D ' => [ 'D ', 'D/' ], 'R ' => [ '=>', '/>' ], ' M' => [ 'M ', '??' ], ' P' => [ '--', '-/' ], } if $is_baz; my $changes = Arch::Changes->new; foreach my $line (@lines) { next if $line =~ /^\*/; next if $line eq ""; # work around baz-1.1 tree-lint messages last if $line =~ /^These files would be source but lack inventory ids/; # support baz if ($is_baz && $line =~ /^([ADR ][ MP]) (.+?)(?: => (.+))?$/) { my $tla_prefix = $baz_1_1_conversion_table->{$1}; die "Unknown 'baz status' line: $line\n" unless $tla_prefix; # baz-1.1 lacks info about dirs, so stat file (may not work) my $is_dir = $1 eq 'R ' ? -d "$self->{dir}/$3" : -d "$self->{dir}/$2"; $line = $tla_prefix->[$is_dir ? 1 : 0] . " $2"; $line .= "\t$3" if $3; } $line =~ m!^([ADM=/-])([ />b-]) ([^\t]+)(?:\t([^\t]+))?$! or die("Unrecognized changes line: $line\n"); my $type = $1; my $is_dir = ($1 eq '/') || ($2 eq '/'); my @args = ($3, $4); # fix tla changes inconsistency with renamed directories ('/>' vs '=/') $type = '=' if $type eq '/'; $changes->add($type, $is_dir, @args); } return $changes; } sub get_changeset ($$) { my $self = shift; my $dir = shift; die("Directory already exists: $dir\n") if (-d $dir); my $cmd = is_baz()? "diff": "changes"; run_tla($cmd, "-d", $self->{dir}, "-o", $dir); return -f "$dir/mod-dirs-index" ? Arch::Changeset->new("changes.".$self->get_version(), $dir) : undef; } sub get_merged_log_text ($) { my $self = shift; my $text = run_tla("log-for-merge", "-d", $self->{dir}); return $text; } sub get_merged_revision_summaries ($) { my $self = shift; my $text = $self->get_merged_log_text; my @hash = (); $text eq "" or $text =~ s/^Patches applied:\n\n// or die "Unexpected merged log output:\n$text\n"; while ($text =~ s/^ \* (.*)\n(.+\n)*\n//) { push @hash, $1; my $summary = $2; $summary =~ s/^ //g; $summary =~ s/\n$//; push @hash, $summary; } die "Unexpected merged log sub-output:\n$text\n" if $text ne ""; return @hash if wantarray; my %hash = @hash; return \%hash; } sub get_merged_revisions ($) { my $self = shift; my $revision_summaries = $self->get_merged_revision_summaries; my @array = sort keys %$revision_summaries; return wantarray ? @array : \@array; } sub get_missing_revisions ($;$) { my $self = shift; my $version = shift || $self->get_version; $self->{missing_revisions}->{$version} ||= [ run_tla("missing", "-d", $self->{dir}, $version) ]; my $array = $self->{missing_revisions}->{$version}; return wantarray ? @$array : $array; } sub get_missing_revision_descs ($;$) { my $self = shift; my $version = shift || $self->get_version; unless ($self->{missing_revision_descs}->{$version}) { my @revision_lines = map { /^\S/? (undef, $_): $_ } run_tla("missing -scD", "-d", $self->{dir}, $version); shift @revision_lines; # throw away first undef my $revision_descs = _parse_revision_descs(4, \@revision_lines); $self->{missing_revision_descs}->{$version} = $revision_descs; $self->{missing_revisions}->{$version} = [ map { $_->{name} } @$revision_descs ]; } return $self->{missing_revision_descs}->{$version}; } # for compatibility only, may be removed after summer 2005 *get_missing_revision_details = *get_missing_revision_descs; *get_missing_revision_details = *get_missing_revision_details; sub get_previous_revision ($;$) { my $self = shift; my $revision = shift || $self->get_revision; return adjacent_revision($revision, -1) unless $revision =~ /^(.*)--version-0$/; # handle version-0 case specially, can't be guessed from the name alone my $revisions = $self->get_log_revisions($1); until (pop @$revisions eq $revision) { } return $revisions->[-1]; } sub get_ancestry_logs ($%) { my $self = shift; my %args = @_; my $limit = $args{limit} || 0; my $callback = $args{callback}; my $one_version = $args{one_version} || 0; my $no_continuation = $args{no_continuation} || 0; my @collected = (); my $version = $self->get_version if $one_version; my $revision = $self->get_revision; while ($revision) { my $log = $self->get_log($revision); # handle removed logs unless ($log) { $revision = $self->get_previous_revision($revision); next; } my $kind = $log->get_revision_kind; if ($kind eq 'import') { $revision = undef; } elsif ($kind eq 'tag') { $revision = $no_continuation ? undef : $log->continuation_of; $revision &&= undef if $one_version && $revision !~ /^\Q$version--/; } else { $revision = $self->get_previous_revision($revision); } push @collected, $callback? $callback->($log): $log; last unless --$limit && $log; # undefined by callback } return \@collected; } # for compatibility only, may be removed after summer 2005 sub iterate_ancestry_logs ($;$$) { my $self = shift; my $cb = shift; my $nc = shift || 0; return $self->get_ancestry_logs(callback => $cb, no_continuation => $nc); } sub get_history_revision_descs ($;$%) { my $self = shift; my $filepath = shift; @_ = (one_version => $_[0]) if @_ == 1; # be compatible until summer 2005 my %args = @_; my $limit = delete $args{limit} || 0; my $callback = delete $args{callback}; my ($is_dir, $changed); if (defined $filepath) { my $full_filepath = "$self->{dir}/$filepath"; # currently stat the existing tree file/dir $is_dir = -l $full_filepath? 0: -d _? 1: -f _? 0: die "No tree file or dir ($full_filepath)\n"; $filepath =~ s!/{2,}!/!g; $filepath =~ s!^/|/$!!g; $filepath = "." if $filepath eq ""; # avoid invalid input die } return $self->get_ancestry_logs(%args, callback => sub { my $log = $_[0]; if (defined $filepath) { $changed = $log->get_changes->is_changed("to", $filepath, $is_dir); return unless defined $changed; } my $revision_desc = $log->get_revision_desc; if (defined $filepath) { $revision_desc->{filepath} = $filepath; $revision_desc->{is_filepath_added} = $changed->{&ADD}? 1: 0; $revision_desc->{is_filepath_renamed} = $changed->{&RENAME}? 1: 0; $revision_desc->{is_filepath_modified} = $changed->{&MODIFY}? 1: 0; $revision_desc->{orig_filepath} = $filepath = $changed->{&RENAME} if $revision_desc->{is_filepath_renamed}; $_[0] = undef if $revision_desc->{is_filepath_added}; } my @returned = $callback ? $callback->($revision_desc, $log) : $revision_desc; $_[0] = undef unless --$limit && $revision_desc; # undefined by callback return @returned; }); } # for compatibility only, may be removed after 2005 *get_ancestry_revision_descs = *get_history_revision_descs; *get_ancestry_revision_descs = *get_ancestry_revision_descs; # parse input like "3-5,8" or [ 3..5, 8 ] or { 3 => 1, 4 => 1, 5 => 1, 8 => 1 } sub _get_skip_hash_from_linenums ($$) { my $linenums = shift; my $max_linenum = shift; my %skip_linenums = (); if (defined $linenums) { %skip_linenums = map { $_ => 1 } 1 .. $max_linenum; if (!ref($linenums)) { $linenums = [ map { die "Invalid line range ($_)\n" unless /^(\d+)?(-|\.\.)?(\d+)?$/; $2? ($1 || 1) .. ($3 || $max_linenum): $1 } split(',', $linenums) ]; } if (ref($linenums) eq 'ARRAY') { $linenums = { map { $_ => 1 } @$linenums }; } if (ref($linenums) eq 'HASH') { delete $skip_linenums{$_} foreach keys %$linenums; } } return \%skip_linenums; } sub _eq ($$) { my $value1 = shift; my $value2 = shift; return defined $value1 && defined $value2 && $value1 == $value2 || !defined $value1 && !defined $value2; } # see tests/tree-annotate-1 to understand input and output sub _group_annotated_lines ($$) { my $lines = shift; my $line_rd_indexes = shift; my $last_line_index = undef; my $last_rd_index = -1; for (my $i = @$lines; @$lines && $i >= 0; $i--) { if ($i == 0 || !_eq($last_rd_index, -1) && !_eq($line_rd_indexes->[$i - 1], $last_rd_index)) { splice(@$line_rd_indexes, $i + 1, $last_line_index - $i); splice(@$lines, $i, $last_line_index - $i + 1, [ @$lines[$i .. $last_line_index] ]); } if ($i > 0 && (_eq($last_rd_index, -1) || !_eq($line_rd_indexes->[$i - 1], $last_rd_index))) { $last_line_index = $i - 1; $last_rd_index = $line_rd_indexes->[$i - 1]; } } } sub get_annotate_revision_descs ($$;%) { my $self = shift; my $filepath = shift || die "No file to annotate\n"; my %args = @_; my $prefetch_callback = delete $args{prefetch_callback}; my $callback = delete $args{callback}; my $linenums = delete $args{linenums}; my $match_re = delete $args{match_re}; my $highlight = delete $args{highlight}; my $full_history = delete $args{full_history}; $linenums ||= [] if $match_re; # no lines by default if regexp given my $full_filepath = "$self->{dir}/$filepath"; die "No file $full_filepath to annotate\n" unless -f $full_filepath; require Arch::DiffParser; my $diff_parser = Arch::DiffParser->new; my @lines; load_file($full_filepath, \@lines); if ($highlight) { require Arch::FileHighlighter; my $fh = Arch::FileHighlighter->instance; my $html_ref = $fh->highlight($full_filepath); chomp($$html_ref); @lines = split(/\n/, $$html_ref, -1); } my @line_rd_indexes = (undef) x @lines; my @line_rd_index_refs = map { \$_ } @line_rd_indexes; my $num_unannotated_lines = @lines; my $num_revision_descs = 0; my $session = Arch::Session->instance; # limit to certain lines only if requested, like "12-24,50-75,100-" my $skip_linenums = _get_skip_hash_from_linenums($linenums, 0 + @lines); if ($match_re) { my $re = eval { qr/$match_re/ }; die "get_annotate_revision_descs: invalid regexp /$match_re/: $@" unless defined $re; $lines[$_ - 1] =~ $re && delete $skip_linenums->{$_} for 1 .. @lines; } $num_unannotated_lines -= keys %$skip_linenums; $line_rd_index_refs[$_ - 1] = undef foreach keys %$skip_linenums; my $revision_descs = $num_unannotated_lines == 0? []: $self->get_history_revision_descs($filepath, %args, callback => sub { my ($revision_desc, $log) = @_; goto FINISH if $num_unannotated_lines == 0; my $old_num_unannotated_lines = $num_unannotated_lines; # there is no diff on import, so include all lines manually if ($log->get_revision_kind eq 'import') { for (my $i = 1; $i <= @line_rd_index_refs; $i++) { my $ref = $line_rd_index_refs[$i - 1]; if ($ref && !$$ref) { $$ref = $num_revision_descs; $num_unannotated_lines--; } } goto FINISH; } # only interested in file addition and modification goto FINISH unless $revision_desc->{is_filepath_modified} || $revision_desc->{is_filepath_added}; # fetch changeset first my $revision = Arch::Name->new($revision_desc->{version}) ->apply($revision_desc->{name}); my $filepath = $revision_desc->{filepath}; $prefetch_callback->($revision, $filepath) if $prefetch_callback; my $changeset = eval { $session->get_revision_changeset($revision); }; # stop if some ancestry archive is not registered or accessible unless ($changeset) { $_[0] = undef; return (); } # get file diff if any my $diff = $changeset->get_patch($filepath); # ignore metadata modification goto FINISH if $diff =~ /^\*/; # calculate annotate data for file lines affected in diff my $changes = $diff_parser->parse($diff)->changes; foreach my $change (reverse @$changes) { my ($ln1, $size1, $ln2, $size2) = @$change; for (my $i = $ln2; $i < $ln2 + $size2; $i++) { die "get_annotate_revision_descs: inconsistent source line #$i in diff:\n" . " $revision\n $filepath\n" . " ($ln1, $size1, $ln2, $size2)\n" if $i > @line_rd_index_refs; my $ref = $line_rd_index_refs[$i - 1]; if ($ref && !$$ref) { $$ref = $num_revision_descs; $num_unannotated_lines--; } } splice(@line_rd_index_refs, $ln2 - 1, $size2, (undef) x $size1); } FINISH: die "get_annotate_revision_descs: inconsistency (some lines left)\n" if $revision_desc->{is_filepath_added} && $num_unannotated_lines > 0; die "get_annotate_revision_descs: inconsistency (got extra lines)\n" if $num_unannotated_lines < 0; # stop "history" processing if all lines are annotated $_[0] = undef if !$full_history && $num_unannotated_lines == 0; # skip "history" revision that does not belong to "annotate" return () if !$full_history && $old_num_unannotated_lines == $num_unannotated_lines; $num_revision_descs++; my @returned = $callback ? $callback->($revision_desc, $log) : $revision_desc; $_[0] = undef unless $revision_desc; # undefined by callback return @returned; }); return $revision_descs unless wantarray; _group_annotated_lines(\@lines, \@line_rd_indexes) if $args{group}; return (\@lines, \@line_rd_indexes, $revision_descs); } sub clear_cache ($;@) { my $self = shift; my @keys = @_; @keys = qw(missing_revision_descs missing_revisions cached_logs) unless @keys; foreach (@keys) { if (@_ && !exist $self->{$_}) { warn __PACKAGE__ . "::clear_cache: unknown key ($_), ignoring\n"; next; } $self->{$_} = {}; } return $self; } sub get_file_diff ($$) { my $self = shift; my $path = shift; my $cwd = getcwd; chdir($self->{dir}); my $cmd = has_file_diffs_cmd()? "file-diffs": "file-diff"; my $diff = run_tla($cmd, "-N", $path); chdir($cwd); return $diff; } sub add ($;@) { my $self = shift; my $opts = shift if ref($_[0]) eq 'HASH'; my @files = @_; my @args = (); push @args, "--id", $opts->{id} if $opts->{id}; push @args, @files; my $cwd = getcwd(); chdir($self->{dir}) && run_tla("add-id", @args); chdir($cwd); return $?; } sub delete ($;@) { my $self = shift; my @files = @_; my $cwd = getcwd(); chdir($self->{dir}) && run_tla("delete-id", @files); chdir($cwd); return $?; } sub move ($;@) { my $self = shift; my @files = @_; my $cwd = getcwd(); chdir($self->{dir}) && run_tla("move-id", @files); chdir($cwd); return $?; } sub make_log ($) { my $self = shift; my ($file) = run_tla("make-log", "-d", $self->{dir}); return $file; } sub import ($;$@) { my $self = shift; return unless ref($self); # ignore perl's import() method my $opts = shift if ref($_[0]) eq 'HASH'; my $version = shift || $self->get_version; my $is_baz = is_baz(); my @args = (); foreach my $opt (qw(archive log summary log-message)) { push @args, "--$opt", $opts->{$opt} if $opts->{$opt}; } push @args, "--setup" unless $is_baz || $opts->{nosetup}; push @args, "--dir" unless $is_baz; push @args, $opts->{dir} || $self->{dir}; # baz-1.2 advertizes but does not actually support directory argument # this block may be deleted later (the bug is fixed in baz-1.3) if ($is_baz) { my $cwd = getcwd(); my $dir = pop @args; chdir($dir) && run_tla("import", @args, $version); chdir($cwd); return $?; } run_tla("import", @args, $version); return $?; } sub commit ($;$) { my $self = shift; my $opts = shift if ref($_[0]) eq 'HASH'; my $version = shift; my @args = (); push @args, "--dir", $self->{dir} unless $opts->{dir}; foreach my $opt (qw(archive dir log summary log-message file-list)) { my $_opt = $opt; $_opt =~ s/-/_/g; push @args, "--$opt", $opts->{$_opt} if $opts->{$_opt}; } foreach my $opt (qw(strict seal fix out-of-date-ok)) { my $_opt = $opt; $_opt =~ s/-/_/g; push @args, "--$opt" if $opts->{$_opt}; } if (has_commit_version_arg()) { push @args, $version || $self->get_version; } elsif ($version) { warn "This arch backend's commit does not support version arg\n"; } my $files = $opts->{files}; if ($files) { die "commit: files is not ARRAY ($files)\n" unless ref($files) eq 'ARRAY'; push @args, "--" if has_commit_files_separator(); push @args, @$files; } run_tla("commit", @args); return $?; } 1; __END__ =head1 NAME Arch::Tree - class representing Arch tree =head1 SYNOPSIS use Arch::Tree; my $tree = Arch::Tree->new; # assume the current dir print map { "$_\n" } $tree->get_log_versions; foreach my $log ($tree->get_logs) { print "-" x 80, "\n"; print $log->standard_date, "\n"; print $log->summary, "\n\n"; print $log->body; } =head1 DESCRIPTION This class represents the working tree concept in Arch and provides some useful methods. =head1 METHODS The following methods are available: B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B. =over 4 =item B [I] Construct the Arch::Tree object associated with the existing directory I. The default is the current '.' directory. =item B Returns the project tree root. =item B Returns the fully qualified tree version. =item B Returns the fully qualified tree revision. =item B I Changes the tree version to I. =item B Returns all version names (including the main one and merged ones) for which logs are stored in the tree. In the scalar context returns arrayref. =item B I Add log version I to project tree. =item B [I] Returns all revision names of the given I (the default is the tree version) for which logs are stored in the tree. In the scalar context returns arrayref. =item B I Return Arch::Log object corresponding to the tree log of the given I. =item B [I] Return Arch::Log objects corresponding to the tree logs of the given I. In the scalar context returns arrayref. The default I is the tree version (see C). A special version name '*' may be used, in this case all logs in C are returned. I may be arrayref as well with the similar results. =item B [I] Returns arrayref of log revision description hashes corresponding to I. The optional I argument may get the same values that are supported by B. =item B Returns L object for the project tree. =item B Returns a list of uncommited changes in the project tree. =item B I Creates an B of the uncommited changes in the tree. The directory I is used to store the changeset and must not already exist. It will not be automatically removed. =item B This is just the output of "tla log-for-merge". =item B Returns hash (actually sorted array of pairs) or hashref in the scalar context. The pair is for every merged revision: full-name => summary. =item B The list of all merged in (present in the changes) full revisions. In the scalar context returns arrayref. =item B [I] The list of all missing revisions corresponding to I. In the scalar context returns arrayref. The default I is the tree version (see C). =item B [I] The hashref of all missing revision descriptions corresponding to I. The hash keys are revisions and the values are hashrefs with keys I, I, I, I, I, I. The default I is the tree version (see C). =item B [] Given the fully qualified revision name (defaulting to B) return the previous namespace revision in this tree version. Return undef for the I revision. Note, the I revision argument is handled specially. =item B [I<%args>] Return all ancestry revision logs (calculated from the tree). The first log in the returned arrayref corresponds to the current tree revision, the last log is normally the original import log. If the tree has certain logs pruned (such practice is not recommended), then such pruned log is not returned and this method tries its best to determine its ancestor, still without accessing the archive. I<%args> accepts: flags I and I, and I to filter a revision log before it is collected. If I is set, then do not follow tags backward. If I is set, then do not follow tags from the versions different than the initial version. This is similar to I, but not the same, since it is possible to tag into the same version. The default callback is effectivelly: sub { my ($log) = @_; return $log; } Note that if the callback does $_[0] = undef among other things, this is taken as a signal to stop processing of ancestry (the return value is still collected even in this case; return empty list to collect nothing). =item B [I [I<%args>]] Return arrayref of all ancestry revision descriptions in the backward order (i.e. from a more recent to an older). If I is given, then only revisions that modified the given file (or dir) are returned. The revision description is hashref with keys I, I, I, I, I, I. If I if given, then the revision description hash additionally contains keys I, I (if renamed on that revision), I, I and I. I<%args> accepts: flags I and I, and I to filter a revision description before it is collected. The default callback is effectivelly: sub { my ($revision_desc, $log) = @_; return $revision_desc; } The I<%args> flags and assigning to $_[0] in callback have the same meaning as in B. =item B [I [I<%args>]] Return file annotation data. In scalar context, returns arrayref of all ancestry revision descriptions in the backward order (i.e. from a more recent to an older) responsible for last modification of all file lines. In list context, returns list of 3 values: ($lines, $line_revision_desc_indexes, $revision_descs) = $tree->get_annotate_revision_descs($filename); $lines is arrayref that contains all I lines with no end-of-line; $line_revision_desc_indexes is arrayref of the same length that contains indexes to the $revision_descs arrayref. Note that $revision_descs is the same returned in the scalar context, it is similar to the one returned by B, but possibly contains less elements, since some revisions only modified metadata, or only modified lines that were modified by other revisions afterward, all such revisions are not included. If some lines can't be annotated (usually, because the history was cut), then the corresonding $line_revision_desc_indexes elements are undefined. I<%args> accepts: flags I and I, and I to filter a revision description before it is collected. The default callback is effectivelly: sub { my ($revision_desc, $log) = @_; return $revision_desc; } The I<%args> flags and assigning to $_[0] in callback have the same meaning as in B and B. Additionally, I is supported. If given, it is called before fetching a changeset, with two arguments: revision, and filename to look at the patch of which. More I<%args> keys are I (either string or arrayref or hashref), I (regular expression to filter lines). And flags I (syntax highlight lines using markup), I (include all file history revision even those that didn't add the current file lines). =item B [key ..] For performance reasons, some method results are cached (memoized in fact). Use this method to explicitly request this cache to be cleared. By default all cached keys are cleared; I may be one of the strings 'missing_revision_descs', 'missing_revisions'. =item B [{ I }] I Add exlicit inventory ids for I. A specific inventory id may be passed via the I hash with the key C. =item B I Delete explicit inventory ids for I. =item B I I Move exlicit file id for I to I. =item B I Get modifications for I as unified diff. =item B Create a new commit log, if it does not yet exist. Returns the filename. =item B [{ I }] [I] Similar to 'tla import'. =item B [{ I }] [I] Commit changes in tree. Note, I argument is not supported in newer baz versions. Optional file limits may be passed using I arrayref in I. =back =head1 BUGS Awaiting for your reports. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =head1 SEE ALSO For more information, see L, L, L, L, L, L. =cut Arch-0.5.2/perllib/Arch/Library.pm0000644000076400007640000002220710313031561015317 0ustar migomigo# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Library; use base 'Arch::Storage'; use Arch::Util qw(run_tla load_file standardize_date parse_creator_email date2age); use Arch::Changeset; use Arch::Log; use Arch::Backend qw(has_revlib_patch_set_dir); use Arch::TempFiles qw(temp_dir); sub _default_fields ($) { my $this = shift; return ( $this->SUPER::_default_fields, fallback_dir => undef, ready_to_add => 0, path => undef, working_revision => undef, revision_trees => {}, ); } sub archives ($) { my $self = shift; return [ run_tla('library-archives') ]; } sub categories ($;$) { my $self = shift; my $archive = shift || $self->working_name; return [ run_tla('library-categories', $archive) ]; } sub branches ($;$) { my $self = shift; my $full_category = shift || $self->working_name; return [ run_tla('library-branches', $full_category) ]; } sub versions ($;$) { my $self = shift; my $full_branch = shift || $self->working_name; return [ run_tla('library-versions', $full_branch) ]; } sub revisions ($;$) { my $self = shift; my $full_version = shift || $self->working_name; return [ run_tla('library-revisions', $full_version) ]; } sub get_revision_descs ($;$) { my $self = shift; my $full_version = shift || $self->working_name; my @lines = run_tla('library-revisions -Dcs', $full_version); my @revision_descs = (); while (@lines) { my ($name, $date, $creator) = splice @lines, 0, 3; die "Unexpected date line ($date) in tla library-revisions -Dcs\n" unless $date =~ s/^ //; die "Unexpected creator line ($creator) in tla library-revisions -Dcs\n" unless $creator =~ s/^ //; my @summary_lines = (); push @summary_lines, shift @lines while @lines && $lines[0] =~ /^ |^\t/; my $summary = join("\n", @summary_lines); $summary =~ s/^ |^\t//mg; $date = standardize_date($date); my $age = date2age($date); my ($creator1, $email, $username) = parse_creator_email($creator); push @revision_descs, { name => $name, summary => $summary, creator => $creator1, email => $email, username => $username, date => $date, age => $age, kind => 'lib', }; } return \@revision_descs; } *revision_details = *get_revision_descs; *revision_details = *revision_details; sub expanded_archive_info ($;$$) { my $self = shift; my $old_working_name = $self->working_name; my $archive_name = shift || $old_working_name; $self->working_name($archive_name); my ($archive, $category0, $branch0) = $self->working_names; my $full_listing = shift || 0; my $infos = []; $self->working_names($archive); foreach my $category ($category0? ($category0): @{$self->categories}) { $self->working_names($archive, $category); push @$infos, [ $category, [] ]; foreach my $branch ($branch0? ("$category--$branch0"): @{$self->branches}) { $branch = "" unless $branch =~ s/^\Q$category\E--//; $self->working_names($archive, $category, $branch); push @{$infos->[-1]->[1]}, [ $branch, [] ]; foreach my $version (@{$self->versions}) { die unless $version =~ s/^\Q$category\E(?:--)?\Q$branch\E--//; $self->working_names($archive, $category, $branch, $version); my $revisions = $self->revisions; my $revisions2 = []; if ($full_listing) { $revisions2 = $revisions; } else { my $revision0 = $revisions->[0] || ''; my $revisionl = $revisions->[-1] || ''; $revisionl = '' if $revision0 eq $revisionl; push @$revisions2, $revision0, $revisionl; } push @{$infos->[-1]->[1]->[-1]->[1]}, [ $version, @$revisions2 ]; } } } $self->working_name($old_working_name); return $infos; } sub fallback_dir ($;$) { my $self = shift; if (@_) { my $dir = shift; $self->{fallback_dir} = $dir; } return $self->{fallback_dir}; } sub working_revision ($;$) { my $self = shift; if (@_) { my $revision = shift; $self->{working_revision} = $revision; } return $self->{working_revision}; } sub add_revision ($$) { my $self = shift; my $revision = shift; unless ($self->{ready_to_add}) { ($self->{path}) = run_tla("my-revision-library --silent --add"); my $fallback_dir = $self->{fallback_dir}; if (!$self->{path} && $fallback_dir) { # don't create more than one directory level to avoid typos mkdir($fallback_dir, 0777) unless -d $fallback_dir; run_tla("my-revision-library $fallback_dir"); ($self->{path}) = run_tla("my-revision-library --silent --add"); } $self->{ready_to_add} = 1 if $self->{path}; } die "Can't attempt to add revision. No revision-library is defined?\n" unless $self->{ready_to_add}; run_tla("library-add --sparse $revision"); my $dir = $self->find_revision_tree($revision); die "Adding revision $revision to library failed.\nBad permissions or corrupt archive?\n" unless $dir; return $dir; } sub find_revision_tree ($$;$) { my $self = shift; my $revision = shift || die "find_revision_tree: No revision given\n"; my $auto_add = shift || 0; return $self->{revision_trees}->{$revision} if $self->{revision_tree}; my ($dir) = run_tla("library-find -s $revision"); if (!$dir && $auto_add) { $dir = $self->add_revision($revision); } return $self->{revision_trees}->{$revision} = $dir; } sub find_tree ($;$) { my $self = shift; $self->find_revision_tree($self->{working_revision}, @_); } sub get_revision_changeset ($$) { my $self = shift; my $revision = shift || die "get_revision_changeset: No revision given\n"; my $dir; if (has_revlib_patch_set_dir()) { my $tree_root = $self->find_revision_tree($revision); die "No revision $revision found in library\n" unless $tree_root; $dir = "$tree_root/,,patch-set"; } else { $dir = temp_dir(); run_tla('get-changeset', $revision, $dir); } return Arch::Changeset->new($revision, $dir); } sub get_changeset ($) { my $self = shift; $self->get_revision_changeset($self->{working_revision}, @_); } sub get_revision_log ($$) { my $self = shift; my $revision = shift || die "get_revision_log: No revision given\n"; my $message; if (has_revlib_patch_set_dir()) { my $tree_root = $self->find_revision_tree($revision); die "No revision $revision found in library\n" unless $tree_root; my $log_file = "$tree_root/,,patch-set/=log.txt"; die "Missing log $log_file in revision library\n" unless -f $log_file; $message = load_file($log_file); } else { $message = run_tla('library-log', $revision); } return Arch::Log->new($message); } sub get_log ($) { my $self = shift; $self->get_revision_log($self->{working_revision}, @_); } 1; __END__ =head1 NAME Arch::Library - access arch revision libraries =head1 SYNOPSIS use Arch::Library; my $library = Arch::Library->new; my $rev = 'migo@homemail.com--Perl-GPL/arch-perl--devel--0--patch-1'; my $log = $library->get_revision_log($rev); my $cset = $library->get_revision_changeset($rev); =head1 DESCRIPTION Arch::Library provides an interface to access pristine trees, changesets and logs stored in local revision libraries. =head1 METHODS The following common methods (inherited and pure virtual that this class implements) are documented in L: B, B, B, B, B, B, B. B, B, B, B, B, B, B, B, B, B, B. Additionally, the following methods are available: B, B, B, B, B. =over 4 =item B [I] Get or set the fallback directory. Defaults to C. If no revision library exists, the fallback directory will be used as revision library when adding revisions with B. =item B [I] Get or set the default revision for B, B and B. =item B I [I] =item B [I] Returns the path to the revision library structure for revision I or B. Returns an empty string if I is not in the revision library and I is not set. If I is set, I will be added to the revision library. =back =head1 BUGS No known bugs. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =head1 SEE ALSO For more information, see L, L, L. =cut Arch-0.5.2/perllib/Arch/FileHighlighter.pm0000644000076400007640000002357410326555050016771 0ustar migomigo# Arch Perl library, Copyright (C) 2004-2005 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::FileHighlighter; use Arch::Util qw(run_cmd load_file save_file); sub new ($;$) { my $class = shift; my $filters = shift; $filters ||= [ (-x '/usr/bin/enscript'? 'enscript': ()), 'internal' ]; my $self = { filters => $filters, }; bless $self, $class; no strict 'refs'; ${"${class}::global_instance"} = $self; return $self; } sub instance ($;$) { my $class = shift; no strict 'refs'; return ${"${class}::global_instance"} || $class->new(@_); } sub htmlize ($) { my $str = shift; die "No content to htmlize" unless defined $str; $str =~ s/&/&/sg; $str =~ s/\"/"/sg; $str =~ s//>/sg; return $str; } sub dehtmlize ($) { my $str = shift; die "No content to dehtmlize" unless defined $str; $str =~ s/&/&/sg; $str =~ s/"/\"/sg; $str =~ s/<//sg; return $str; } sub highlight ($$;$) { my $self = shift; my $file_name = shift; my $content = shift; load_file($file_name, \$content) unless defined $content; my $content_ref = ref($content) eq 'SCALAR'? $content: \$content; return undef if -B $file_name; foreach (@{$self->{filters}}) { # make sure we actually copy $_ and not work in-place my $filter = $_; my %args = (); if ($filter =~ /(.*)\((.*)\)/) { $filter = $1; my $args = $2; %args = map { /^(.+?)=(.*)$/? ($1 => $2): ($_ => 1) } split(/[^:\w=]+/, $args); } my $method = "_highlight_$filter"; unless ($self->can($method)) { warn qq(Arch::FileHighlighter: unknown filter "$filter"\n); next; } my $html_ref = $self->$method($file_name, $content_ref, %args); return $html_ref if $html_ref; } $self->_highlight_none($file_name, $content_ref); } sub _highlight_enscript ($$$%) { my $self = shift; my $file_name = shift; my $content_ref = shift; my %args = @_; my $tmp; if ($content_ref) { require Arch::TempFiles; $tmp = Arch::TempFiles->new; $file_name =~ m!^(.*/|^)([^/]+)$! || die "Invalid file name ($file_name)\n"; $file_name = $tmp->dir("highlight") . "/$2"; save_file($file_name, $content_ref); } my @enscript_args = qw(enscript --output - --quiet --pretty-print); push @enscript_args, "--color" unless $args{"mono"}; push @enscript_args, "--language", "html", $file_name; my $html = eval { run_cmd(@enscript_args) }; return undef unless $html; $html =~ s!^.*
\n?!!s; $html =~ s!
.*$!!s; return undef unless $args{"asis"} || $html =~ /($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; $html =~ s!($dot*?)!$1!sg; } $html =~ s!(.*?)!$1!sg; $html =~ s!(.*?)!$1!sg; $html =~ s!!!sg; # enscript bug with perl highlightling $html =~ s!(\r?\n)((?:)+)!$2$1!g; return \$html; } sub _match_file_extension ($$) { my $file_name = shift; my $args = shift; while (my ($ext, $value) = each %$args) { return 1 if $value && $file_name =~ /\.$ext(\.in)?$/i; } return 0; } sub _highlight_internal ($$$%) { my $self = shift; my $file_name = shift; my $content_ref = shift; my %args = @_; my @xml_extensions = qw(html htm shtml sgml xml wml rss glade); my $xml_extension_regexp = join('|', @xml_extensions); if (%args) { if (exists $args{':xml'}) { my $value = delete $args{':xml'}; $args{$_} = $value foreach @xml_extensions; } return undef unless _match_file_extension($file_name, \%args); } print STDERR "internal highlighting for $file_name\n" if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\1") ne "\0"; my $html = htmlize($$content_ref); $file_name =~ s/\.in$//; $file_name = lc($file_name); if ($file_name =~ /\.(ac|am|conf|m4|pl|pm|po|py|rb|sh|sql)$/ || $html =~ /^#!/) { $html =~ s!^([ \t]*)(#.*)!$1$2!mg; } if ($file_name =~ /\.(lisp|lsp|scm|scheme)$/) { $html =~ s!^([ \t]*)(;.*)!$1$2!mg; } if ($file_name =~ /\.(c|cc|cpp|cxx|c\+\+|h|hpp|idl|php|xpm|l|y)$/) { $html =~ s!(^|[^\\:])(//.*)!$1$2<\/span>!g; $html =~ s!(^|[^\\])(/\*.*?\*/)!$1$2<\/span>!sg; } if ($file_name =~ /(^configure(\.ac)?|\.m4)$/) { $html =~ s!(\bdnl\b.*)!$1<\/span>!g; $html =~ s!\b(m4_\w+)\b!$1<\/span>!g; $html =~ s!\b(if|then|else|fi)\b!$1<\/span>!g; } if ($file_name =~ /\.($xml_extension_regexp)$/) { $html =~ s!(<\!--.*?-->)!$1<\/span>!sg; $html =~ s!(</?\w+.*?>)!$1<\/span>!sg; while ($html =~ s!(>(?:<[\w-]+)?\s+)([\w-]+)(=)("[^"]*"|'[^']'|[^\s]*)!$1$2<\/span>$3$4<\/span>!sg) {} } return \$html; } sub _highlight_none ($$$%) { my $self = shift; my $file_name = shift; my $content_ref = shift; my %args = @_; if (%args) { return undef unless _match_file_extension($file_name, \%args); } my $html = htmlize($$content_ref); return \$html; } 1; __END__ =head1 NAME Arch::FileHighlighter - syntax-highlight file's content using markup =head1 SYNOPSIS use Arch::FileHighlighter; my $fh = Arch::FileHighlighter->new( [ 'internal(pm+c)', 'none(txt), 'enscript', 'internal', ] ); my $html_ref = $fh->highlight($0); print $$html_ref; print ${$fh->highlight('file.c', '/* some code */')}; =head1 DESCRIPTION This class processes file contents and produces syntax highlighting markup. This may be used together with css that defines exact text colors and faces. The default is to use the builtin "internal" processing, that is pretty poor; only very basic file types and syntax constructions are supported. It is suggested to configure and use the external "enscript" utility. GNU enscript understands quite a rich number of file types and produces a useful syntax highlighting. "enscript" filter is used by default if /usr/bin/enscript is found. It is possible to configure different filters ("none", "internal", "enscript") depending on file name extension. In any case the resulting markup is always unified, i.e. all special characters are HTML-encoded using SGML entities, and the markup that looks like Espanclass="syntax_foo"EbarE/spanE is used. =head1 METHODS The following methods are available: B, B, B. =over 4 =item B [I] Create a new instance of L. I is arrayref of strings of the form I(ext1+ext2+...)", where I is one of "enscript", "internal" or "none". Special extension ":xml" is a shortcut for "html+htm+sgml+xml+wml+rss+glade". The filters optionally constrained by file extensions are probed sequentially and the first passed one is used. Note that if enscript is configured in the sequence, but is not installed, then its probing may print a warning to stderr. The "enscript" filter is handled a bit specially, it may take parameters "mono" (less colors) and "asis" instead of the file extensions. If enscript returns html without any tags, then the filter is handled as failed, unless "asis" is given. By default, I is [ 'internal' ], or [ 'enscript', 'internal' ] depending on presense of '/usr/bin/enscript'. =item B [I] Alternative constructor. Return the last created instance of L or create a new one. The purpose of this alternative constructor is to allow the singleton behaviour as well as certain Aspect Oriented Programming practices. =item B I [I] Process I using configured filters (as described in the constructor) and produce the file content with embeded Espan class="I"E...E/spanE markup. I is one of: syntax_keyword syntax_builtin syntax_comment syntax_special syntax_funcdef syntax_vartype syntax_string syntax_constant If I is provided (either string or reference to string), it is used, otherwise the content of I is loaded. =back =head1 BUGS Awaiting for your reports. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). =head1 SEE ALSO For more information, see L, L, L. =cut Arch-0.5.2/perllib/Arch/Util.pm0000644000076400007640000002723211345206773014652 0ustar migomigo# Arch Perl library, Copyright (C) 2004-2005 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Util; # import 2 functions for backward compatibility only; remove after summer 2005 use Arch::Backend qw(arch_backend is_baz); use Exporter; use vars qw(@ISA @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw( arch_backend is_baz run_pipe_from run_cmd run_tla is_tla_functional load_file save_file copy_dir remove_dir setup_config_dir standardize_date date2daysago date2age parse_creator_email adjacent_revision _parse_revision_descs ); sub run_pipe_from (@) { my $arg0 = shift || die; my @args = (split(' ', $arg0), @_); @args = ("'" . join("' '", map { s/'/'"'"'/g; $_ } @args) . "'") # " if $] < 5.008; print STDERR "executing: '" . join("' '", @args) . "'\n" if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\1") ne "\0"; # perl-5.005 does not pass compilation without "eval"... my $pipe_success = $] >= 5.006? eval qq{ no warnings; open(PIPE, '-|', \@args) }: open(PIPE, "$args[0]|"); die "Can't start (@args): $!\n" unless $pipe_success; return \*PIPE; } # in scalar context return the output string, in list context - list of lines sub run_cmd (@) { my $arg0 = shift || die; my @args = (split(' ', $arg0), @_); my $pipe = run_pipe_from(@args); local $/ = undef unless wantarray; my @lines = <$pipe>; close($pipe); chomp @lines if wantarray; return wantarray? @lines: $lines[0] || ""; } sub run_tla (@) { my $arg1 = shift || die; unshift @_, $Arch::Backend::EXE, split(' ', $arg1); goto \&run_cmd; } sub is_tla_functional () { eval { run_tla("help --help") } ? 1 : 0; } sub load_file ($;$) { my $file_name = shift; my $content_ref = shift; print STDERR "load_file: $file_name\n" if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\4") ne "\0"; open(FILE, "<$file_name") or die "Can't load $file_name: $!\n"; local $/ = undef; my $content = ; close(FILE) or die "Can't close $file_name in load: $!\n"; if ($content_ref) { $$content_ref = $content if ref($content_ref) eq 'SCALAR'; if (ref($content_ref) eq 'ARRAY') { $content =~ s/\r?\n$//; @$content_ref = map { chomp; $_ } split(/\r?\n/, $content, -1); } } return defined wantarray? $content: undef; } sub save_file ($$) { my $file_name = shift; print STDERR "save_file: $file_name\n" if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\4") ne "\0"; open(FILE, ">$file_name") or die "Can't save $file_name: $!\n"; print FILE ref($_[0]) eq 'SCALAR'? ${$_[0]}: ref($_[0]) eq 'ARRAY'? map { m|$/$|? $_: "$_$/" } @{$_[0]}: $_[0]; close(FILE) or die "Can't close $file_name in save: $!\n"; return 1; } sub copy_dir ($$) { my $dir1 = shift; my $dir2 = shift; my $out = run_cmd("/bin/cp -PRp", $dir1, $dir2); warn $out if $out; } sub remove_dir (@) { my @dirs = grep { $_ } @_; return unless @dirs; my $out = run_cmd("/bin/rm -rf", @dirs); warn $out if $out; } sub setup_config_dir (;$@) { my $dir = shift; $dir ||= $ENV{ARCH_MAGIC_DIR}; $dir ||= ($ENV{HOME} || "/tmp") . "/.arch-magic"; foreach my $subdir ("", @_) { next unless defined $subdir; $dir .= "/$subdir" unless $subdir eq ""; stat($dir); die "$dir exists, but it is not a writable directory\n" if -e _ && !(-d _ && -w _); unless (-e _) { print STDERR "making dir: $dir\n" if $ENV{DEBUG} && ("$ENV{DEBUG}" & "\2") ne "\0"; mkdir($dir, 0777) or die "Can't mkdir $dir: $!\n"; } } return $dir; } my %months = ( Jan => 1, Feb => 2, Mar => 3, Apr => 4, May => 5, Jun => 6, Jul => 7, Aug => 8, Sep => 9, Oct => 10, Nov => 11, Dec => 12, ); sub standardize_date ($) { my $date = shift; if ($date =~ /\w+ (\w+) +(\d+) +(\d+):(\d+):(\d+) (\w+) (\d+)/) { $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d %s", $7, $months{$1} || 88, $2, $3, $4, $5, $6); } return $date; } # return (creator_name, creator_email, creator_username) sub parse_creator_email ($) { my $creator = shift; my $email = 'no@email.defined'; my $username = "_none_"; if ($creator =~ /^(.*?)\s*<((?:(.+?)@)?.*)>$/) { ($creator, $email, $username) = ($1, $2, $3); } return ($creator, $email, $username); } sub adjacent_revision ($$) { my $full_revision = shift; my $offset = shift || die "adjacent_revision: no offset given\n"; die "adjacent_revision: no working revision\n" unless $full_revision; $full_revision =~ /^(.*--.*?)(\w+)-(\d+)$/ or die "Invalid revision ($full_revision)\n"; my $prefix = $1; my $new_num = $3 + $offset; return undef if $new_num < 0; my $new_word = $2 =~ /^patch|base$/? $new_num? 'patch': 'base': $new_num? 'versionfix': 'version'; return "$prefix$new_word-$new_num"; } sub date2daysago ($) { my $date_str = shift; return -10000 unless $date_str =~ /^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2}) ([^\s]+)/; # timezone is not taken in account... require Time::Local; my $time = Time::Local::timegm($6, $5, $4, $3, $2 - 1, $1 - 1900); my $daysago = int((time - $time) / 60 / 60 / 24); return $daysago unless wantarray; return ($daysago, $time, $7); } sub date2age ($) { my $daysago = date2daysago($_[0]); return "bad-date" if $daysago <= -10000; my ($sign, $days) = $daysago =~ /^(-?)(.*)$/; my $str = $days == 1? "1 day": $days <= 33? "$days days": $days <= 59? int($days / 7 + 0.5) . " weeks": $days <= 550? int($days / 30.42 + 0.5) . " months": int($days / 365.25 + 0.5) . " years"; return "$sign$str"; } # gets tla lines with undef meaning the delimiter for revisions; # intended for parsing of "abrowse --desc" and "logs --cDs" sub _parse_revision_descs ($$) { my $num_spaces = shift || die; my $revision_lines = shift || die; my $spaces = " " x $num_spaces; $spaces || die "Invalid number of spaces ($num_spaces)"; my @revision_descs = (); while (@$revision_lines) { my ($line1, $line2) = splice @$revision_lines, 0, 2; my @summary_lines = (); push @summary_lines, shift @$revision_lines while defined $revision_lines->[0]; shift @$revision_lines; # throw away undef delimiter my $summary = join("\n", @summary_lines); $line2 =~ s/^$spaces//; $summary =~ s/^$spaces//mg; my ($name, $kind) = $line1 =~ /^(\S+)(?:\s+\((.*?)\))?/ or die "Unexpected output of tla, subline 1:\n\t$line1\n"; $kind = !$kind? "unknown": $kind =~ /tag/? "tag": $kind =~ /import/? "import": "cset"; my ($date, $creator) = $line2 =~ /^(.+?)\s{6}(.*)/ or die "Unexpected output of tla, subline 2:\n\t$line2\n"; $date = standardize_date($date); my $age = date2age($date); my @version_part; push @version_part, 'version', $1 if $name =~ s/^(.*)--(.*)/$2/; my ($creator1, $email, $username) = parse_creator_email($creator); push @revision_descs, { name => $name, summary => $summary, creator => $creator1, email => $email, username => $username, date => $date, age => $age, kind => $kind, @version_part, }; } return \@revision_descs; } 1; __END__ =head1 NAME Arch::Util - Arch utility functions =head1 SYNOPSIS use Arch::Util qw(run_tla load_file save_file setup_config_dir); my $abrowse_output = run_tla('abrowse --summary --date --creator'); my ($full_version) = run_tla('tree-version'); my @full_revisions = run_tla('logs', '-r', '-f'); my $cfg_dir = setup_config_dir(undef, "archipelago"); my $content = load_file("$cfg_dir/versions.cfg"); $content =~ s/^last_version = .*/last_version = $full_version/m; save_file("$cfg_dir/versions.cfg", $content); =head1 DESCRIPTION A set of helper functions suitable for GNU Arch related projects in Perl. Higher (object oriented) levels of Arch/Perl library make use of these helper functions. =head1 FUNCTIONS The following functions are available: B, B, B, B, B, B, B, B, B, B, B, B, B. The system functions die on errors. =over 4 =item B Verify whether the system has a working arch backend installed (and possibly configured by environment variables, like TLA or ARCH_BACKEND), needed for this perl library to function. =item B I =item B I arg ... Run the given I subcommand with optional arguments. Return the tla output in the scalar context, and a list of B-ed lines in the list context. =item B I =item B I I ... Run the given shell command (like I or I) with optional arguments. Return the command output in the scalar context, and a list of B-ed lines in the list context. B is implemented using B. =item B I =item B I I ... Run the given shell command (like I or I) with optional arguments in the separate process. Return the pipe (file handle) that may be used to read the command output from. B is implemented using B. =item B I =item B I I =item B I I Load the given I. Return the file content if the returning value is expected. As a side effect, may modify the I or I if given, in the last case all file lines are split and B-ed. =item B I I Save the given I in the given I. The I may be either scalar, scalar ref, or array ref (see B). =item B I I Copy I to I recursivelly, preserving as many attributes as possible. =item B I .. Remove I (or dirs) recusivelly. Please be careful. =item B =item B I =item B I I ... Create (if needed) the configuration I that defaults to either $ARCH_MAGIC_DIR or I<~/.arch-magic> or I if $HOME is unset. If one or more consecutive I given, repeat the same procedure for the sub-directory (including creating and diagnostics if needed). Return a name of the existing directory (including sub-directories if any). =item B I Try to convert the given date string to "yyyy-mm-dd HH:MM:SS TMZ". If failed, the original string is returned. =item B I Convert a date string to time difference to now in full days. In list content, return (num_days_ago, unix_time, timezone_str). =item B I Like B, but return a human readable string, like "5 days" or "-6 weeks" or "7 months" or "3 years". =item B I Try to parse the I B of the patch creator. Return a list of his/her name and email. =item B I I Given the I and positive or negative offset, try to guess the full name of the adjacent revision. =back =head1 BUGS Awaiting for your reports. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). =head1 SEE ALSO For more information, see L, L. =cut Arch-0.5.2/perllib/Arch/Session.pm0000644000076400007640000003555410335770456015370 0ustar migomigo# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::Session; use base 'Arch::Storage'; use Arch::Util qw(run_tla _parse_revision_descs load_file save_file); use Arch::Backend qw(get_cache_config); use Arch::TempFiles qw(temp_dir_name temp_dir); use Arch::Changeset; use Arch::Library; use Arch::Log; use Arch::Tree; use Arch::Tarball; sub _default_fields ($) { my $this = shift; return ( $this->SUPER::_default_fields, use_library => 1, ); } sub new ($%) { my $class = shift; my %init = @_; my $self = $class->SUPER::new(%init); $self->clear_cache; return $self; } sub archives ($) { my $self = shift; $self->{archives} ||= [ run_tla("archives -n") ]; return $self->{archives}; } *is_archive_registered = *Arch::Storage::is_archive_managed; *is_archive_registered = *is_archive_registered; sub categories ($;$) { my $self = shift; my $archive = $self->_name_operand(shift, 'archive'); unless ($self->{categories}->{$archive}) { $self->{categories}->{$archive} = [ run_tla("categories", $archive) ]; } return $self->{categories}->{$archive}; } sub branches ($;$) { my $self = shift; my $category = $self->_name_operand(shift, 'category'); unless ($self->{branches}->{$category}) { $self->{branches}->{$category} = [ run_tla("branches", $category) ]; } return $self->{branches}->{$category}; } sub versions ($;$) { my $self = shift; my $branch = $self->_name_operand(shift, 'branch'); unless ($self->{versions}->{$branch}) { $self->{versions}->{$branch} = [ run_tla("versions", $branch) ]; # temporarily do this for backward compatibility $self->{versions}->{$branch} = [ map { s/--/----/; $_ } grep !/--.*--/, @{$self->{versions}->{$branch}} ] if $branch->branch eq ''; } return $self->{versions}->{$branch}; } sub revisions ($;$) { my $self = shift; my $version = $self->_name_operand(shift, 'version'); unless ($self->{revisions}->{$version}) { $self->{revisions}->{$version} = [ run_tla("revisions", $version) ]; } return $self->{revisions}->{$version}; } sub get_revision_descs ($;$$) { my $self = shift; my $version = $self->_name_operand(shift, 'version'); my $extra_args = shift || []; die "get_revision_descs: no a|c|b|v ($version)\n" unless $version->is_valid('archive+'); unless ($self->{revision_descs}->{$version}) { my $nonarch_version = $version->nan; # $ok is used to work around the tla bug with branchless version # $prev_line is used to track revisions with no (empty) summary my $ok = 0; my $prev_line = ""; my @revision_lines = map { s/^ //? $_: undef } grep { $ok = /^ \Q$nonarch_version\E$/ if /^ [^ ]/; my $end = ($prev_line =~ /^ /) && ($_ eq ""); $prev_line = $_; ($end || /^ /) && $ok } run_tla("abrowse --desc", @$extra_args, $version); my $revision_descs = _parse_revision_descs(2, \@revision_lines); $self->{revision_descs}->{$version} = $revision_descs; $self->{revisions}->{$version} = [ map { $_->{name} } @$revision_descs ]; } return $self->{revision_descs}->{$version}; } *revision_details = *get_revision_descs; *revision_details = *revision_details; sub clear_cache ($;@) { my $self = shift; my @keys = @_; @keys = qw(archives categories branches versions revisions revision_descs) unless @keys; foreach (@keys) { if (@_ && !exist $self->{$_}) { warn __PACKAGE__ . "::clear_cache: unknown key ($_), ignoring\n"; next; } $self->{$_} = $_ eq 'archives'? undef: {}; } return $self; } sub expanded_versions ($;$$) { my $self = shift; my $archive = $self->_name_operand(shift); my $extra_args = shift || []; die "get_all_versions: no archive+ ($archive)\n" unless $archive->is_valid('archive+'); my $archive0 = $archive->cast('archive'); unless ($self->{all_versions}->{$archive}) { my @versions = map { s/^ //; "$archive0/$_" } grep { /^ [^ ]/ } run_tla("abrowse --desc", @$extra_args, $archive); $self->{all_versions}->{$archive} = \@versions; } return $self->{all_versions}->{$archive}; } # [ # [ category1, [ # [ branch1, [ # [ version1, start_revision1, end_revision1 ], # [ version2, start_revision2, end_revision2 ], # ] ], # [ branch2, [ # [ version3, start_revision3, end_revision3 ], # [ version4, start_revision4, end_revision4 ], # ] ], # ..., # ] ], # ] sub expanded_archive_info ($;$$) { my $self = shift; my $archive_plus = $self->_name_operand(shift); my $full_listing = shift || 0; # currently ignored my $infos = []; my @category_infos = split(/^\b/m, join('', map { s/^ //; "$_\n" } grep { /^ / } run_tla("abrowse $archive_plus") )); my $error = 0; CATEGORY_ITEM: foreach (@category_infos) { my ($category, $branch_infos) = /^([^\s]+)\n( .*)$/s; push @$infos, [ $category, [] ]; unless (defined $category) { $error = 1; next CATEGORY_ITEM; } my @branch_infos = split(/^\b/m, join('', map { s/^ // or $error = 1; "$_\n" } split("\n", $branch_infos) )); $error = 1 unless @branch_infos; foreach (@branch_infos) { my ($branch, $version_infos) = /^\Q$category\E(?:--([^\s]+))?\n( .*)$/s; $branch = "" if defined $version_infos && !defined $branch; unless (defined $branch) { $error = 1; next CATEGORY_ITEM; } push @{$infos->[-1]->[1]}, [ $branch, [] ]; my @version_infos = split(/^\b/m, join('', map { s/^ // or $error = 1; "$_\n" } split("\n", $version_infos) )); $error = 1 unless @version_infos; foreach (@version_infos) { my ($version, $revision0, $revisionl) = /^\Q$category\E(?:--)?\Q$branch\E--([^\s]+)(?:\n ([^\s]+)(?: \.\. ([^\s]+))?\n)?$/s; unless (defined $version) { $error = 1; next CATEGORY_ITEM; } my $revisions2 = []; if ($full_listing) { push @$revisions2, $revision0 if defined $revision0; push @$revisions2, $revisionl if defined $revisionl; } else { $revision0 = '' unless defined $revision0; $revisionl = '' unless defined $revisionl; push @$revisions2, $revision0, $revisionl; } push @{$infos->[-1]->[1]->[-1]->[1]}, [ $version, @$revisions2 ]; } } } continue { if ($error) { warn "Unexpected abrowse output, skipping:\n$_\n"; pop @$infos; $error = 0; } } return $infos; } sub get_revision_changeset ($$;$) { my $self = shift; my $revision = shift; my $dir = shift; # use revlib unless specific result dir requested (and unless disabled) if (!$dir && $self->{use_library}) { $dir = Arch::Library->instance->find_revision_tree($revision); if ($dir) { $dir .= "/,,patch-set"; goto RETURN_CHANGESET; } } # use arch cache if available my $cache_dir = get_cache_config()->{dir}; if (!$dir && $cache_dir) { my $delta_file = "$cache_dir/archives/$revision/delta.tar.gz"; if (-r $delta_file) { my $tarball = Arch::Tarball->new(file => $delta_file); my $subdir = $revision; $subdir =~ s!.*/!!; $dir = $tarball->extract . "/$subdir.patches"; $dir = "" unless -d $dir; goto RETURN_CHANGESET if $dir; } } $dir ||= temp_dir_name("arch-changeset"); die "get_changeset: incorrect dir ($dir)\n" unless $dir && !-d $dir; run_tla("get-changeset", $revision, $dir); RETURN_CHANGESET: return Arch::Changeset->new($revision, $dir); } sub get_changeset ($;$) { my $self = shift; my $dir = shift; my $revision = $self->working_name; die "get_changeset: no working revision\n" unless $revision->is_valid('revision'); return $self->get_revision_changeset($revision, $dir); } sub get_specified_changeset ($$) { my $self = shift; my $arg = shift; die "No changeset specifier (revision name or directory)\n" unless $arg; my $downloaded_file = undef; my $temp_dir = undef; if ($arg =~ m!^http://!) { die "Invalid http:// tarball url ($arg)\n" unless $arg =~ m!/([^/]+\.tar\.gz)$!; my $filename = $1; require Arch::LiteWeb; my $web = Arch::LiteWeb->new; my $content = $web->get($arg); die $web->error_with_url unless defined $content; die "Zero content in $arg\n" unless $content; $temp_dir = temp_dir("arch-download"); $arg = "$temp_dir/$filename"; save_file($arg, \$content); $downloaded_file = $arg; } if ($arg =~ m!([^/]+)\.tar\.gz$!) { die "No tarball file $arg found\n" unless -f $arg; my $basename = $1; require Arch::Tarball; my $tarball = Arch::Tarball->new(file => $arg); my $final_dir = $tarball->extract(dir => $temp_dir) . "/$basename"; # base-0.src.tar.gz tarball extracts to dir without .src part, # but this tree has no tree-version set anyway (and zero changes) die "No way to get tree changes from what seems to be an arch import tarball\n File: $arg\n" if $final_dir =~ /.*--.*--.*\d+\.src$/ && !-d $final_dir; die "No expected $final_dir after extracting $arg\n" unless -d $final_dir; $arg = $final_dir; unlink $downloaded_file if $downloaded_file; } if (-d "$arg/{arch}") { my $tree = Arch::Tree->new($arg); my $cset = $tree->get_changeset(temp_dir_name("arch-changeset")); die qq(Could not get local tree changes\n) . qq( You may be using "untagged-source unrecognized" and have untagged source\n) . qq( files in your tree. Please add file ids or remove the offending files.\n) unless defined $cset; return $cset; } elsif (-f "$arg/mod-dirs-index") { return Arch::Changeset->new('none', $arg); } elsif (-d $arg) { die qq(Invalid directory\n) . qq( "$arg" is neither a changeset directory nor a project tree.\n); } else { # die "No fully qualified revision name ($arg)\n" # unless Arch::Name->is_valid($arg, "revision"); my $cset = eval { $self->get_revision_changeset( $arg, temp_dir_name("arch-changeset") ); }; die qq(get-changeset failed\n) . qq( Could not fetch changeset for revision "$arg".\n) if $@; return $cset; } } sub get_revision_log ($$) { my $self = shift; my $revision = shift || die "get_revision_log: No revision given\n"; my $message; # use arch cache if available my $cache_dir = get_cache_config()->{dir}; if ($cache_dir) { my $log_file = "$cache_dir/archives/$revision/log"; if (-r $log_file) { load_file($log_file, \$message); goto RETURN_LOG; } } $message = run_tla("cat-archive-log", $revision); die "Can't get log of $revision from archive.\n" . "Unexisting revision or system problems.\n" unless $message; RETURN_LOG: return Arch::Log->new($message); } sub get_log ($) { my $self = shift; my $revision = $self->working_name; die "get_log: no working revision\n" unless $revision->is_valid('revision'); return $self->get_revision_log($revision); } sub get_tree ($;$$%) { my $self = shift; my $opts = shift if ref($_[0]) eq 'HASH'; my $revision = $self->_name_operand(shift); die "get_tree: no r|v|b ($revision)\n" unless $revision->is_valid('branch+'); my $dir = shift || temp_dir_name("arch-tree"); die "get_tree: no directory name (internal error?)\n" unless $dir; die "get_tree: directory already exists ($dir)\n" if -d $dir; my @args = (); push @args, "--no-pristine" unless $opts->{pristine}; push @args, "--link" if $opts->{link}; push @args, "--library" if $opts->{library}; push @args, "--sparse" if $opts->{sparse}; push @args, "--non-sparse" if $opts->{non_sparse}; push @args, "--no-greedy-add" if $opts->{no_greedy_add}; run_tla("get --silent", @args, $revision, $dir); die "Can't get revision $revision from archive.\n" . "Unexisting revision or system problems.\n" unless -d $dir; return Arch::Tree->new($dir); } sub init_tree ($$;$) { my $self = shift; my $version = $self->_name_operand(shift, "version"); my $dir = shift || "."; run_tla("init-tree", "-d", $dir, $version); return undef unless $? == 0; return Arch::Tree->new($dir); } sub my_id ($;$) { my $self = shift; my $userid = shift; if (defined $userid) { return 0 unless $userid =~ /<.+\@.*>/; run_tla("my-id", $userid); return !$?; } else { ($userid) = run_tla("my-id"); return $userid; } } 1; __END__ =head1 NAME Arch::Session - access arch archives =head1 SYNOPSIS use Arch::Session; my $session = Arch::Session->new; my $rev = 'migo@homemail.com--Perl-GPL/arch-perl--devel--0--patch-1'; my $log = $session->get_revision_log($rev); my $cset = $session->get_revision_changeset($rev); my $tree = $session->get_tree($rev); =head1 DESCRIPTION Arch::Session provides an interface to access changesets and logs stored in arch archives. =head1 METHODS The following common methods (inherited and pure virtual that this class implements) are documented in L: B, B, B, B, B, B, B. B, B, B, B, B, B, B, B, B, B, B. Additionally, the following methods are available: B, B, B, B, B. =over 4 =item B I Get changeset object (Arch::Changeset) by a user specified input. I may be revision name, or changeset directory, or tree directory (then changeset for tree changes is constructed), and in the future local tarball filepath or remote tarball url. =item B [I ..] For performance reasons, most method results are cached (memoized in fact). Use this method to explicitly request this cache to be cleared. By default all cached keys are cleared; I may be one of the strings 'archives', 'categories', 'branches', 'versions', 'revisions' or 'revision_descs'. =item B [{ I }] [I [I]] Construct a working tree for I or B in I. If I is not specified, a new temporary directory is automatically created. Keys of I may be I, I, I, I, I, I; all are false by default. See C. =item B I Run C in I. =item B [I] Get or set C. =back =head1 BUGS No known bugs. =head1 AUTHORS Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel). Enno Cramer (uebergeek@web.de--2003/arch-perl--devel). =head1 SEE ALSO For more information, see L, L, L, L, L, L. =cut Arch-0.5.2/perllib/Arch/SharedIndex.pm0000644000076400007640000003644410313055023016120 0ustar migomigo# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA use 5.005; use strict; package Arch::SharedIndex; sub new ($%) { my $class = shift; my %init = @_; my $file = $init{file} or die "No index file given\n"; my $can_create = exists $init{can_create}? $init{can_create}: 1; my $time_renewal = exists $init{time_renewal}? $init{time_renewal}: $init{max_size}? 1: 0; my $self = { file => $file, can_create => $can_create, max_size => int($init{max_size} || 0), expiration => int($init{expiration} || 0), time_renewal => $time_renewal, perl_data => $init{perl_data} || 0, perl_data_indent => $init{perl_data_indent} || 0, perl_data_pair => $init{perl_data_pair} || "=>", }; bless $self, $class; return $self; } sub encode_value ($$) { my $self = shift; return unless $self->{perl_data}; my $value = shift; # Data::Dumper is one of the silly-API modules; configure every time. # Object oriented API is a bit slower and less backward compatible. # Avoid unused variable warnings by separate declaration/assignment. require Data::Dumper; local $Data::Dumper::Indent; local $Data::Dumper::Pair; local $Data::Dumper::Quotekeys; local $Data::Dumper::Terse; $Data::Dumper::Indent = $self->{perl_data_indent}; $Data::Dumper::Pair = $self->{perl_data_pair}; $Data::Dumper::Quotekeys = 0; $Data::Dumper::Terse = 1; $$value = Data::Dumper->Dump([$$value]); } sub decode_value ($$) { my $self = shift; return unless $self->{perl_data}; my $value = shift; $$value = eval $$value; } sub delete_value ($$$) { my $self = shift; my ($key, $token) = @_; # super class implementation } sub fetch_value ($$$) { my $self = shift; my ($key, $token) = @_; # super class implementation my $value = $token; $self->decode_value(\$value); return $value; } sub store_value ($$$) { my $self = shift; my ($key, $token, $value) = @_; # super class implementation $self->encode_value(\$value); $token = $value; return $token; } sub index_list_to_hash ($$) { my $self = shift; my $index_list = shift; my $index_hash = {}; foreach my $entry (@$index_list) { $index_hash->{$entry->[0]} = $entry; } return $index_hash; } sub _do_delete ($$$) { my $self = shift; my $index_list = shift; my $keys = shift; my %keys = map { $_ => 1 } @$keys; for (my $num = @$index_list - 1; %keys && $num >= 0; $num--) { my $index_entry = $index_list->[$num]; my ($key, $token) = @$index_entry; next unless $keys{$key}; $self->delete_value($key, $token); splice(@$index_list, $num, 1); delete $keys{$key}; } return @$keys - keys %keys; } sub _do_fetch ($$$) { my $self = shift; my $index_list = shift; my $keys = shift; my @values = (); my $index_hash = $self->index_list_to_hash($index_list); my $time; foreach my $key (@$keys) { my $index_entry = $index_hash->{$key}; my $value = $index_entry? $self->fetch_value(@$index_entry): undef; if (defined $value && $self->{time_renewal}) { $time ||= time(); $index_entry->[2] = $time; } push @values, $value; } return \@values; } sub _do_store ($$$) { my $self = shift; my $index_list = shift; my @new_key_values = @{shift()}; my $entries_stored = 0; my $index_hash = $self->index_list_to_hash($index_list); my $time = time; my %seen = (); while (my ($key, $value) = splice(@new_key_values, 0, 2)) { next if $seen{$key}; $seen{$key} = 1; my $old_entry = $index_hash->{$key}; my $old_token = $old_entry? $old_entry->[1]: undef; my $new_token = $self->store_value($key, $old_token, $value); next unless defined $new_token; my $new_entry = [ $key, $new_token, $time ]; if (defined $old_entry) { @$old_entry = @$new_entry; } else { push @$index_list, $new_entry; } $entries_stored++; } return $entries_stored; } sub delete ($@) { my $self = shift; my $keys = ref($_[0]) eq 'ARRAY'? shift: [ @_ ]; my $entries_deleted; $self->query_index_list(sub ($) { my $index_list = shift; $entries_deleted = $self->_do_delete($index_list, $keys); }); return $entries_deleted; } sub fetch ($@) { my $self = shift; my $single_ref = ref($_[0]) eq 'ARRAY'; my $keys = $single_ref? shift: [ @_ ]; my $values = []; $self->query_index_list(sub ($) { my $index_list = shift; $values = $self->_do_fetch($index_list, $keys); }); return $single_ref? $values: wantarray? @$values: $values->[0]; } sub store ($%) { my $self = shift; my $new_key_values = ref($_[0]) eq 'HASH'? [ %{shift()} ]: # unordered ref($_[0]) eq 'ARRAY'? shift: [ @_ ]; # ordered my $entries_stored; $self->query_index_list(sub ($) { my $index_list = shift; $entries_stored = $self->_do_store($index_list, $new_key_values); }); return $entries_stored; } sub fetch_store ($$@) { my $self = shift; my $code = shift || die "No code given"; my $single_ref = ref($_[0]) eq 'ARRAY'; my $keys = $single_ref? shift: [ @_ ]; my $values; $self->query_index_list(sub ($) { my $index_list = shift; $values = $self->_do_fetch($index_list, $keys); my (@new_keys, @missing_idxs); my $run_idx = 0; @new_keys = grep { (defined $values->[$run_idx]? 0: push @missing_idxs, $run_idx) * ++$run_idx } @$keys; if ($ENV{DEBUG} && ("$ENV{DEBUG}" & "\2") ne "\0") { my $status = @new_keys? @new_keys == @$keys? "miss": "partial hit-miss": "hit"; my $keystr = join(', ', @$keys); substr($keystr, 57) = "..." if length($keystr) > 60; print STDERR "Shared fetch_store ($keystr): $status\n"; } return unless @new_keys; my @new_key_values = map { $_ => ref($code) ne 'CODE'? $code: &$code($_) } @new_keys; my $num_stored = $self->_do_store($index_list, \@new_key_values); warn "fetch_store: not all new values are actually stored\n" if $num_stored < @new_keys; @$values[@missing_idxs] = @new_key_values[map { $_ * 2 + 1 } 0 .. @new_keys - 1]; }); return $single_ref? $values: wantarray? @$values: $values->[0]; } sub keys ($) { my $self = shift; my @keys; $self->query_index_list(sub ($) { my $index_list = shift; @keys = map { $_->[0] } @$index_list; }); return wantarray? @keys: \@keys; } sub values ($) { my $self = shift; my @values; $self->query_index_list(sub ($) { my $index_list = shift; @values = map { $self->fetch_value(@$_) } @$index_list; }); return wantarray? @values: \@values; } sub hash ($) { my $self = shift; my %hash; $self->query_index_list(sub ($) { my $index_list = shift; %hash = map { $_->[0] => $self->fetch_value(@$_) } @$index_list; }); return wantarray? %hash: \%hash; } sub list ($) { my $self = shift; my @list; $self->query_index_list(sub ($) { my $index_list = shift; @list = map { [ $_->[0] => $self->fetch_value(@$_) ] } @$index_list; }); return wantarray? @list: \@list; } sub grep ($;$) { my $self = shift; my $code = shift || sub { $_[1] }; my @keys; $self->query_index_list(sub ($) { my $index_list = shift; @keys = map { $_->[0] } grep { &$code($_->[0], $self->fetch_value(@$_)) } @$index_list; }); return wantarray? @keys: \@keys; } sub filter ($;$) { my $self = shift; my $code = shift || sub { $_[1] }; my @keys; $self->query_index_list(sub ($) { my $index_list = shift; @keys = map { $_->[0] } grep { &$code($_->[0], $self->fetch_value(@$_)) } @$index_list; $self->_do_delete($index_list, \@keys); }); return wantarray? @keys: \@keys; } sub update ($$;$) { my $self = shift; my $code = shift; my $grep_code = shift; die "No code or value given" unless defined $code; my $entries_updated; $self->query_index_list(sub ($) { my $index_list = shift; $entries_updated = $self->_do_store($index_list, [ map { $_->[0] => ref($code) ne 'CODE'? $code: &$code($_->[0], $self->fetch_value(@$_)) } grep { $grep_code? &$grep_code( $_->[0], $self->fetch_value(@$_)): 1 } @$index_list ]); }); return $entries_updated; } sub query_index_list ($$) { my $self = shift; my $code = shift; my $file = $self->{file}; if (!-f $file && $self->{can_create}) { open FH, ">$file" or die "Can't create index file ($file)\n"; close FH; } -f $file or die "No index file ($file)\n"; open FH, "+<$file" or die "Can't open $file for updating: $!\n"; flock FH, 2; # wait for exclusive lock seek FH, 0, 0; # rewind to beginning my @content = ; # get current content chomp @content; my $index_list = [ grep { defined } map { /^(\d+)\t(.+?)\t(.*)/? [ $2, $3, $1 ]: warn("Corrupt line ($_) in $file; ignored\n"), undef } @content ]; if ($self->{expiration}) { my $time = time(); my $diff = $self->{expiration}; my @expired_keys = map { $_->[0] } grep { $time - $_->[2] > $diff } @$index_list; $self->_do_delete($index_list, \@expired_keys) if @expired_keys; } # apply callback filter &$code($index_list); if ($self->{max_size} && @$index_list > $self->{max_size}) { my @excess_nums = (0 .. @$index_list - $self->{max_size} - 1); my @excess_keys = map { $_->[0] } (@$index_list)[@excess_nums]; $self->_do_delete($index_list, \@excess_keys); } my @new_content = map { "$_->[2]\t$_->[0]\t$_->[1]" } @$index_list; my $is_changed = join('', @content) ne join('', @new_content); if ($is_changed) { seek FH, 0, 0; # rewind again truncate FH, 0; # empty the file print FH map { "$_$/" } @new_content; } close FH; # release file } 1; __END__ =head1 NAME Arch::SharedIndex - a synchronized data structure (map) for IPC =head1 SYNOPSIS use Arch::SharedIndex; my $map = Arch::SharedIndex->new(file => "/tmp/logintimes.idx"); my $time = time; $map->store(migo => $time - 75, bob => $time - 5, enno => $time); printf "All users: %s, %s, %s\n", $map->keys; printf "New users: %s\n", $map->grep(sub { $_[1] == $time }); printf "Login time of migo: %s\n", $map->fetch('migo'); $map->update(sub { $_[1] + 10 }, sub { $_[1] == $time }); $map->store(migo => $time); $map->delete('bob'); printf "Logged users with times: (%s)\n", join(", ", $map->hash); =head1 DESCRIPTION Arch::SharedIndex provides a key-value map that can be shared and accessed safely by multiple processes. =head1 METHODS The following methods are available: B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B, B. =over 4 =item B I Create a new index object. I