diff options
Diffstat (limited to 'rt/sbin')
27 files changed, 7937 insertions, 1327 deletions
diff --git a/rt/sbin/extract-message-catalog b/rt/sbin/extract-message-catalog index 44f8d51..ce151bd 100644 --- a/rt/sbin/extract-message-catalog +++ b/rt/sbin/extract-message-catalog @@ -2,8 +2,8 @@ # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -59,12 +59,17 @@ use vars qw($DEBUG $FILECAT); $DEBUG = 1; -@ARGV = <lib/RT/I18N/*.po> unless @ARGV; +# po dir is for extensions +@ARGV = (<lib/RT/I18N/*.po>, <lib/RT/I18N/*.pot>, <po/*.po>, <po/*.pot>) unless @ARGV; $FILECAT = {}; # extract all strings and stuff them into $FILECAT -File::Find::find( { wanted => \&extract_strings_from_code, follow => 1 }, '.' ); +# scan html dir for extensions +File::Find::find( { wanted => \&extract_strings_from_code, follow => 1 }, qw(bin sbin lib share html etc) ); + +# remove msgid with $ in it. XXX: perhaps give some warnings here +$FILECAT = { map { $_ => $FILECAT->{$_} } grep { !m/\$/ } keys %$FILECAT }; # ensure proper escaping and [_1] => %1 transformation foreach my $str ( sort keys %{$FILECAT} ) { @@ -83,11 +88,13 @@ foreach my $str ( sort keys %{$FILECAT} ) { # update all language dictionaries foreach my $dict (@ARGV) { + $dict = "lib/RT/I18N/$dict.pot" if ( $dict eq 'rt' ); $dict = "lib/RT/I18N/$dict.po" unless -f $dict or $dict =~ m!/!; my $lang = $dict; $lang =~ s|.*/||; $lang =~ s|\.po$||; + $lang =~ s|\.pot$||; update($lang, $dict); } @@ -101,7 +108,8 @@ sub extract_strings_from_code { local $/; return if ( -d $_ ); return if ( $File::Find::dir =~ 'lib/blib|lib/t/autogen|var|m4|local' ); - return if ( /\.po$|\.bak$|~|,D|,B$|extract-message-catalog$/ ); + return if ( /\.(?:pot|po|bak|gif|png|psd|jpe?g|svg|css|js)$/ ); + return if ( /~|,D|,B$|extract-message-catalog$|tweak-template-locstring$/ ); return if ( /^[\.#]/ ); return if ( -f "$_.in" ); @@ -115,12 +123,20 @@ sub extract_strings_from_code { return; } + my $re_space_wo_nl = qr{(?!\n)\s}; + my $re_loc_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc $re_space_wo_nl* $}x; + my $re_loc_qw_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_qw $re_space_wo_nl* $}x; + my $re_loc_pair_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_pair $re_space_wo_nl* $}x; + my $re_loc_left_pair_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_left_pair $re_space_wo_nl* $}x; + my $re_delim = $RE{delimited}{-delim=>q{'"}}{-keep}; + $_ = <_>; # Mason filter: <&|/l>...</&> my $line = 1; while (m!\G.*?<&\|/l(.*?)&>(.*?)</&>!sg) { my ( $vars, $str ) = ( $1, $2 ); + $vars =~ s/[\n\r]//g; $line += ( () = ( $& =~ /\n/g ) ); # cryptocontext! $str =~ s/\\'/\'/g; #print "STR IS $str\n"; @@ -136,7 +152,7 @@ sub extract_strings_from_code { my ( $vars, $str ); if ( $match =~ - /\(\s*($RE{delimited}{-delim=>q{'"}}{-keep})(.*?)\s*\)$/s ) { + /\(\s*($re_delim)(.*?)\s*\)$/so ) { $str = substr( $1, 1, -1 ); # $str comes before $vars now $vars = $9; @@ -154,20 +170,59 @@ sub extract_strings_from_code { # Comment-based mark: "..." # loc $line = 1; pos($_) = 0; - while (m/\G.*?($RE{delimited}{-delim=>q{'"}}{-keep})[\}\)\],]*\s*\#\s*loc\s*$/smg) { - my $str = substr($1, 1, -1); + while (m/\G.*?($re_delim)[\}\)\],;]*$re_loc_suffix/smgo) { + my $str = $1; $line += ( () = ( $& =~ /\n/g ) ); # cryptocontext! - $str =~ s/\\'/\'/g; + unless ( defined $str ) { + warn "Couldn't process loc at $filename:$line"; + next; + } + $str = substr($str, 1, -1); + $str =~ s/\\'/\'/g; push @{ $FILECAT->{$str} }, [ $filename, $line, '' ]; } + # Comment-based qw mark: "qw(...)" # loc_qw + $line = 1; + pos($_) = 0; + while (m/\G.*?(?:(qw\([^)]+\))[\}\)\],;]*)?$re_loc_qw_suffix/smgo) { + my $str = $1; + $line += ( () = ( $& =~ /\n/g ) ); # cryptocontext! + unless ( defined $str ) { + warn "Couldn't process loc_qw at $filename:$line"; + next; + } + foreach my $value (eval($str)) { + push @{ $FILECAT->{$value} }, [ $filename, $line, '' ]; + } + } + + # Comment-based left pair mark: "..." => ... # loc_left_pair + $line = 1; + pos($_) = 0; + while (m/\G.*?(?:(\w+)\s*=>[^#\n]+?)?$re_loc_left_pair_suffix/smgo) { + my $key = $1; + $line += ( () = ( $& =~ /\n/g ) ); # cryptocontext! + unless ( defined $key ) { + warn "Couldn't process loc_left_pair at $filename:$line"; + next; + } + $key =~ s/\\'/\'/g; + push @{ $FILECAT->{$key} }, [ $filename, $line, '' ]; + } + # Comment-based pair mark: "..." => "..." # loc_pair $line = 1; pos($_) = 0; - while (m/\G.*?(\w+)\s*=>\s*($RE{delimited}{-delim=>q{'"}}{-keep})[\}\)\],]*\s*\#\s*loc_pair\s*$/smg) { + while (m/\G.*?(?:(\w+)\s*=>\s*($re_delim)[\}\)\],;]*)?$re_loc_pair_suffix/smgo) { my $key = $1; - my $val = substr($2, 1, -1); + my $val = $2; $line += ( () = ( $& =~ /\n/g ) ); # cryptocontext! + unless ( defined $key && defined $val ) { + warn "Couldn't process loc_pair at $filename:$line"; + next; + } + $val = substr($val, 1, -1); $key =~ s/\\'/\'/g; $val =~ s/\\'/\'/g; push @{ $FILECAT->{$key} }, [ $filename, $line, '' ]; @@ -196,19 +251,52 @@ sub update { @lines = grep { !/^(#(:|\.)\s*|$)/ } @lines; while (@lines) { my $msghdr = ""; - $msghdr .= shift @lines while ( $lines[0] && $lines[0] !~ /^msgid/ ); + $msghdr .= shift @lines while ( $lines[0] && $lines[0] !~ /^(#~ )?msgid/ ); my $msgid = ""; - $msgid .= shift @lines while ( $lines[0] && $lines[0] =~ /^(msgid|")/ ); + +# '#~ ' is the prefix of launchpad for msg that's not found the the source +# we'll remove the prefix later so we can still show them with our own mark + + $msgid .= shift @lines while ( $lines[0] && $lines[0] =~ /^(#~ )?(msgid|")/ ); my $msgstr = ""; - $msgstr .= shift @lines while ( $lines[0] && $lines[0] =~ /^(msgstr|")/ ); + $msgstr .= shift @lines while ( $lines[0] && $lines[0] =~ /^(#~ )?(msgstr|")/ ); last unless $msgid; chomp $msgid; chomp $msgstr; - $msgid =~ s/^msgid "(.*)"\s*?$/$1/ms or warn "$msgid in $file"; - $msgstr =~ s/^msgstr "(.*)"\s*?$/$1/ms or warn "$msgstr in $file"; + + $msgid =~ s/^#~ //mg; + $msgstr =~ s/^#~ //mg; + + $msgid =~ s/^msgid "(.*)"\s*?$/$1/m or warn "$msgid in $file"; + + if ( $msgid eq '' ) { + # null msgid, msgstr will have head info + $msgstr =~ s/^msgstr "(.*)"\s*?$/$1/ms or warn "$msgstr in $file"; + } + else { + $msgstr =~ s/^msgstr "(.*)"\s*?$/$1/m or warn "$msgstr in $file"; + } + + if ( $msgid ne '' ) { + for my $msg ( \$msgid, \$msgstr ) { + if ( $$msg =~ /\n/ ) { + my @lines = split /\n/, $$msg; + $$msg = + shift @lines; # first line don't need to handle any more + for (@lines) { + if (/^"(.*)"\s*$/) { + $$msg .= $1; + } + } + } + + # convert \\n back to \n + $$msg =~ s/(?!\\)\\n/\n/g; + } + } $Lexicon{$msgid} = $msgstr; $Header{$msgid} = $msghdr; @@ -217,7 +305,7 @@ sub update { my $is_english = ( $lang =~ /^en(?:[^A-Za-z]|$)/ ); foreach my $str ( sort keys %{$FILECAT} ) { - $Lexicon{$str} ||= '';; + $Lexicon{$str} ||= ''; } foreach ( sort keys %Lexicon ) { my $f = join ( ' ', sort map $_->[0].":".$_->[1], @{ $FILECAT->{$_} } ); @@ -250,7 +338,7 @@ sub update { $var =~ s/\s*$//; $out .= "#. ($var)\n" unless $seen{$var}++; } - $out .= "msgid \"$_\"\nmsgstr \"$Lexicon{$_}\"\n\n"; + $out .= 'msgid ' . fmt($_) . "msgstr \"$Lexicon{$_}\"\n\n"; } open PO, ">$file" or die $!; @@ -266,6 +354,23 @@ sub escape { return $text; } +sub fmt { + my $str = shift; + return "\"$str\"\n" unless $str =~ /\n/; + + my $multi_line = ($str =~ /\n(?!\z)/); + $str =~ s/\n/\\n"\n"/g; + + if ($str =~ /\n"$/) { + chop $str; + } + else { + $str .= "\"\n"; + } + return $multi_line ? qq(""\n"$str) : qq("$str); +} + + __END__ # Local variables: # c-indentation-style: bsd diff --git a/rt/sbin/factory b/rt/sbin/factory index 6b2d896..78a0159 100644 --- a/rt/sbin/factory +++ b/rt/sbin/factory @@ -2,8 +2,8 @@ # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -49,6 +49,8 @@ use strict; use DBI; +die "Usage: $0 database namespace" if @ARGV != 2; + my $database = shift; my $namespace = shift; @@ -65,8 +67,8 @@ my $LicenseBlock = << '.'; # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2004 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2008 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -86,7 +88,9 @@ my $LicenseBlock = << '.'; # # 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., 675 Mass Ave, Cambridge, MA 02139, USA. +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. # # # CONTRIBUTION SUBMISSION POLICY: @@ -110,6 +114,7 @@ my $LicenseBlock = << '.'; . my $Attribution = << '.'; + # Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>) # WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST. # @@ -124,7 +129,7 @@ my $dsn = "DBI:$driver:database=$database;host=$hostname"; my $dbh = DBI->connect( $dsn, $user, $password ); #get all tables out of database -my @tables = $dbh->tables(); +my @tables = map { s/^\`\Q$database\E\`\.//; $_ } $dbh->tables(); my ( %tablemap, $typemap, %modulemap ); diff --git a/rt/sbin/license_tag b/rt/sbin/license_tag index ddb4368..f638db6 100644 --- a/rt/sbin/license_tag +++ b/rt/sbin/license_tag @@ -4,8 +4,8 @@ # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -51,8 +51,8 @@ my $LICENSE = <<'EOL'; COPYRIGHT: - -This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC + +This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC <jesse@bestpractical.com> (Except where explicitly superseded by other copyright notices) @@ -101,7 +101,7 @@ use File::Find; my @MAKE = qw(Makefile); File::Find::find({ no_chdir => 1, wanted => \&tag_pm}, 'lib'); -File::Find::find({ no_chdir => 1, wanted => \&tag_mason}, 'html'); +File::Find::find({ no_chdir => 1, wanted => \&tag_mason}, 'share/html'); File::Find::find({ no_chdir => 1, wanted => \&tag_script}, 'sbin'); File::Find::find({ no_chdir => 1, wanted => \&tag_script}, 'bin'); tag_makefile ('Makefile.in'); @@ -110,16 +110,16 @@ tag_makefile ('README'); sub tag_mason { my $pm = $_; - next unless (-f $pm); - next if ($pm =~ /images/); + return unless (-f $pm); + return if $pm =~ /images/ || $pm =~ /\.(?:png|jpe?g|gif)$/; open(FILE,"<$pm") || die "Failed to open $pm"; my $file = (join "", <FILE>); close (FILE); + print "$pm - "; + return if another_license($pm => $file) && print "has different license\n"; + my $pmlic = $LICENSE; $pmlic =~ s/^/%# /mg; - - - print "$pm - "; if ($file =~ /^%# BEGIN BPS TAGGED BLOCK {{{/ms) { print "has license section"; $file =~ s/^%# BEGIN BPS TAGGED BLOCK {{{(.*?)%# END BPS TAGGED BLOCK }}}/%# BEGIN BPS TAGGED BLOCK {{{\n$pmlic%# END BPS TAGGED BLOCK }}}/ms; @@ -147,11 +147,11 @@ sub tag_makefile { open(FILE,"<$pm") || die "Failed to open $pm"; my $file = (join "", <FILE>); close (FILE); + print "$pm - "; + return if another_license($pm => $file) && print "has different license\n"; + my $pmlic = $LICENSE; $pmlic =~ s/^/# /mg; - - - print "$pm - "; if ($file =~ /^# BEGIN BPS TAGGED BLOCK {{{/ms) { print "has license section"; $file =~ s/^# BEGIN BPS TAGGED BLOCK {{{(.*?)# END BPS TAGGED BLOCK }}}/# BEGIN BPS TAGGED BLOCK {{{\n$pmlic# END BPS TAGGED BLOCK }}}/ms; @@ -180,11 +180,11 @@ sub tag_pm { open(FILE,"<$pm") || die "Failed to open $pm"; my $file = (join "", <FILE>); close (FILE); + print "$pm - "; + return if another_license($pm => $file) && print "has different license\n"; + my $pmlic = $LICENSE; $pmlic =~ s/^/# /mg; - - - print "$pm - "; if ($file =~ /^# BEGIN BPS TAGGED BLOCK {{{/ms) { print "has license section"; $file =~ s/^# BEGIN BPS TAGGED BLOCK {{{(.*?)# END BPS TAGGED BLOCK }}}/# BEGIN BPS TAGGED BLOCK {{{\n$pmlic# END BPS TAGGED BLOCK }}}/ms; @@ -194,7 +194,7 @@ sub tag_pm { print "no license section"; $file ="# BEGIN BPS TAGGED BLOCK {{{\n$pmlic# END BPS TAGGED BLOCK }}}\n". $file; } - $file =~ s/# END BPS TAGGED BLOCK }}}(\n+)/# END BPS TAGGED BLOCK }}}\n/mg; + $file =~ s/# END BPS TAGGED BLOCK }}}(\n+)/# END BPS TAGGED BLOCK }}}\n\n/mg; print "\n"; @@ -213,10 +213,11 @@ sub tag_script { open(FILE,"<$pm") || die "Failed to open $pm"; my $file = (join "", <FILE>); close (FILE); + print "$pm - "; + return if another_license($pm => $file) && print "has different license\n"; + my $pmlic = $LICENSE; $pmlic =~ s/^/# /msg; - - print "$pm - "; if ($file =~ /^# BEGIN BPS TAGGED BLOCK {{{/ms) { print "has license section"; $file =~ s/^# BEGIN BPS TAGGED BLOCK {{{(.*?)# END BPS TAGGED BLOCK }}}/# BEGIN BPS TAGGED BLOCK {{{\n$pmlic# END BPS TAGGED BLOCK }}}/ms; @@ -241,3 +242,15 @@ sub tag_script { } +sub another_license { + my $name = shift; + my $file = shift; + + return 1 if ($name =~ /(?:FCKEditor|scriptaculous)/i); + + return 0 if $file =~ /Copyright\s+\(c\)\s+\d\d\d\d-\d\d\d\d Best Practical Solutions/i; + return 1 if $file =~ /\b(copyright|GPL|Public Domain)\b/i; # common + return 1 if $file =~ /\(c\)\s+\d\d\d\d(?:-\d\d\d\d)?/i; # prototype + return 0; +} + diff --git a/rt/sbin/merge-rosetta.pl b/rt/sbin/merge-rosetta.pl new file mode 100644 index 0000000..1c4b903 --- /dev/null +++ b/rt/sbin/merge-rosetta.pl @@ -0,0 +1,102 @@ +#!/usr/bin/perl -w +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use LWP::Simple 'getstore'; +use Locale::PO; +use Locale::Maketext::Extract; +use Archive::Extract; +use File::Temp; +use File::Copy 'copy'; + +my $url = shift or die 'must provide rosseta download url or directory'; + +my $dir; + +if ($url =~ m/http/) { + $dir = File::Temp::tempdir; + my ($fname) = $url =~ m{([^/]+)$}; + print "Downloading $url\n"; + getstore($url => "$dir/$fname"); + print "Extracting $dir/$fname\n"; + my $ae = Archive::Extract->new(archive => "$dir/$fname"); + my $ok = $ae->extract( to => $dir ); +} +else { + $dir = $url; +} + +Locale::Maketext::Lexicon::set_option('use_fuzzy', 1); +Locale::Maketext::Lexicon::set_option('allow_empty', 1); + +for (<$dir/rt/*.po>) { + my ($name) = m/([\w_]+)\.po/; + my $fname = "lib/RT/I18N/$name"; + my $tmp = File::Temp->new; + + print "$_ -> $fname.po\n"; + + # retain the "NOT FOUND IN SOURCE" entries + system("sed -e 's/^#~ //' $_ > $tmp"); + my $ext = Locale::Maketext::Extract->new; + $ext->read_po($tmp); + + my $po_orig = Locale::PO->load_file_ashash("$fname.po"); + # don't want empty vales to override ours. + # don't want fuzzy flag as when uploading to rosetta again it's not accepted by rosetta. + foreach my $msgid ($ext->msgids) { + my $entry = $po_orig->{Locale::PO->quote($msgid)} or next; + my $msgstr = $entry->dequote($entry->{msgstr}) or next; + $ext->set_msgstr($msgid, $msgstr) + if $ext->msgstr($msgid) eq '' && $msgstr; + } + $ext->write_po("$fname.po"); +} + +print "Merging new strings\n"; +system("$^X sbin/extract-message-catalog"); diff --git a/rt/sbin/rt-attributes-viewer b/rt/sbin/rt-attributes-viewer new file mode 100755 index 0000000..3dad3ae --- /dev/null +++ b/rt/sbin/rt-attributes-viewer @@ -0,0 +1,110 @@ +#!/usr/bin/perl +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use warnings; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } +} + +my $id = shift; +usage() unless $id; + +sub usage { + print STDERR <<END; +Usage: $0 <attribute id> + +Description: + +This script deserializes and print content of an attribute defined +by <attribute id>. May be useful for developers and for troubleshooting +problems. + +END + exit 1; +} + +require RT; +RT::LoadConfig(); +RT::Init(); + +require RT::Attribute; +my $attr = RT::Attribute->new( do { no warnings 'once'; $RT::SystemUser } ); +$attr->Load( $id ); +unless ( $attr->id ) { + print STDERR "Couldn't load attribute #$id\n"; + exit 1; +} + +my %res = (); +$res{$_} = $attr->$_() foreach qw(ObjectType ObjectId Name Description Content ContentType); + +use Data::Dumper; +print "Content of attribute #$id: ". Dumper( \%res ); + diff --git a/rt/sbin/rt-attributes-viewer.in b/rt/sbin/rt-attributes-viewer.in new file mode 100644 index 0000000..a511289 --- /dev/null +++ b/rt/sbin/rt-attributes-viewer.in @@ -0,0 +1,110 @@ +#!@PERL@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use warnings; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } +} + +my $id = shift; +usage() unless $id; + +sub usage { + print STDERR <<END; +Usage: $0 <attribute id> + +Description: + +This script deserializes and print content of an attribute defined +by <attribute id>. May be useful for developers and for troubleshooting +problems. + +END + exit 1; +} + +require RT; +RT::LoadConfig(); +RT::Init(); + +require RT::Attribute; +my $attr = RT::Attribute->new( do { no warnings 'once'; $RT::SystemUser } ); +$attr->Load( $id ); +unless ( $attr->id ) { + print STDERR "Couldn't load attribute #$id\n"; + exit 1; +} + +my %res = (); +$res{$_} = $attr->$_() foreach qw(ObjectType ObjectId Name Description Content ContentType); + +use Data::Dumper; +print "Content of attribute #$id: ". Dumper( \%res ); + diff --git a/rt/sbin/rt-clean-sessions b/rt/sbin/rt-clean-sessions new file mode 100755 index 0000000..0092a48 --- /dev/null +++ b/rt/sbin/rt-clean-sessions @@ -0,0 +1,190 @@ +#!/usr/bin/perl +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use warnings; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } +} + +use Getopt::Long; +my %opt; +GetOptions( \%opt, "older=s", "debug", "help", "skip-user"); + + +if ( $opt{help} ) { + require Pod::Usage; + import Pod::Usage; + pod2usage({ -message => "RT Session cleanup tool\n", verbose => 1 }); + exit 1; +} + + +if( $opt{'older'} ) { + unless( $opt{'older'} =~ /^\s*([0-9]+)\s*(H|D|M|Y)?$/i ) { + print STDERR "wrong format of the 'older' argumnet\n"; + exit(1); + } + my ($num,$unit) = ($1, uc($2 ||'D')); + my %factor = ( H => 60*60 ); + $factor{'D'} = $factor{'H'}*24; + $factor{'M'} = $factor{'D'}*31; + $factor{'Y'} = $factor{'D'}*365; + $opt{'older'} = $num * $factor{ $unit }; +} + +require RT; +RT::LoadConfig(); + +if( $opt{'debug'} ) { + RT->Config->Set( LogToScreen => 'debug' ); +} else { + RT->Config->Set( LogToScreen => undef ); +} + +RT::ConnectToDatabase(); +RT::InitLogging(); + +require RT::Interface::Web::Session; + +if( $opt{'older'} or my $alogoff = int RT->Config->Get('AutoLogoff') ) { + my $min; + foreach ($alogoff*60, $opt{'older'}) { + next unless $_; + $min = $_ unless $min; + $min = $_ if $_ < $min; + } + + RT::Interface::Web::Session->ClearOld( $min ); +} + +RT::Interface::Web::Session->ClearByUser + unless $opt{'skip-user'}; + +exit(0); + +__END__ + +=head1 NAME + +rt-clean-sessions - clean old and duplicate RT sessions + +=head1 SYNOPSIS + + rt-clean-sessions [--debug] [--older <NUM>[H|D|M|Y]] + + rt-clean sessions + rt-clean sessions --debug + rt-clean sessions --older 10D + rt-clean sessions --debug --older 1M + rt-clean sessions --older 10D --skip-user + +=head1 DESCRIPTION + +Script cleans RT sessions from DB or dir with sessions data. +Leaves in DB only one session per RT user and sessions that aren't older +than specified(see options). + +Script is safe because data in the sessions is temporary and can be deleted. + +=head1 OPTIONS + +=over 4 + +=item older + +Date interval in the C<< <NUM>[<unit>] >> format. Default unit is D(ays), +H(our), M(onth) and Y(ear) are also supported. + +For exmaple: C<rt-clean sessions --older 1M> would delete all sessions that are +older than 1 month. + +=item skip-user + +By default only one session per user left in the DB, so users that have +sessions on multiple computers or in different browsers will be logged out. +Use this option to avoid this. + +=item debug + +Turn on debug output. + +=back + +=head1 NOTES + +Functionality similar to this is implemented in +html/Elements/SetupSessionCookie ; however, that does not guarantee +that a session will be removed from disk and database soon after the +timeout expires. This script, if run from a cron job, will ensure +that the timed out sessions are actually removed from disk; the Mason +component just ensures that the old sessions are not reusable before +the cron job gets to them. + +=cut diff --git a/rt/sbin/rt-clean-sessions.in b/rt/sbin/rt-clean-sessions.in new file mode 100644 index 0000000..ac736e6 --- /dev/null +++ b/rt/sbin/rt-clean-sessions.in @@ -0,0 +1,190 @@ +#!@PERL@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use warnings; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } +} + +use Getopt::Long; +my %opt; +GetOptions( \%opt, "older=s", "debug", "help", "skip-user"); + + +if ( $opt{help} ) { + require Pod::Usage; + import Pod::Usage; + pod2usage({ -message => "RT Session cleanup tool\n", verbose => 1 }); + exit 1; +} + + +if( $opt{'older'} ) { + unless( $opt{'older'} =~ /^\s*([0-9]+)\s*(H|D|M|Y)?$/i ) { + print STDERR "wrong format of the 'older' argumnet\n"; + exit(1); + } + my ($num,$unit) = ($1, uc($2 ||'D')); + my %factor = ( H => 60*60 ); + $factor{'D'} = $factor{'H'}*24; + $factor{'M'} = $factor{'D'}*31; + $factor{'Y'} = $factor{'D'}*365; + $opt{'older'} = $num * $factor{ $unit }; +} + +require RT; +RT::LoadConfig(); + +if( $opt{'debug'} ) { + RT->Config->Set( LogToScreen => 'debug' ); +} else { + RT->Config->Set( LogToScreen => undef ); +} + +RT::ConnectToDatabase(); +RT::InitLogging(); + +require RT::Interface::Web::Session; + +if( $opt{'older'} or my $alogoff = int RT->Config->Get('AutoLogoff') ) { + my $min; + foreach ($alogoff*60, $opt{'older'}) { + next unless $_; + $min = $_ unless $min; + $min = $_ if $_ < $min; + } + + RT::Interface::Web::Session->ClearOld( $min ); +} + +RT::Interface::Web::Session->ClearByUser + unless $opt{'skip-user'}; + +exit(0); + +__END__ + +=head1 NAME + +rt-clean-sessions - clean old and duplicate RT sessions + +=head1 SYNOPSIS + + rt-clean-sessions [--debug] [--older <NUM>[H|D|M|Y]] + + rt-clean sessions + rt-clean sessions --debug + rt-clean sessions --older 10D + rt-clean sessions --debug --older 1M + rt-clean sessions --older 10D --skip-user + +=head1 DESCRIPTION + +Script cleans RT sessions from DB or dir with sessions data. +Leaves in DB only one session per RT user and sessions that aren't older +than specified(see options). + +Script is safe because data in the sessions is temporary and can be deleted. + +=head1 OPTIONS + +=over 4 + +=item older + +Date interval in the C<< <NUM>[<unit>] >> format. Default unit is D(ays), +H(our), M(onth) and Y(ear) are also supported. + +For exmaple: C<rt-clean sessions --older 1M> would delete all sessions that are +older than 1 month. + +=item skip-user + +By default only one session per user left in the DB, so users that have +sessions on multiple computers or in different browsers will be logged out. +Use this option to avoid this. + +=item debug + +Turn on debug output. + +=back + +=head1 NOTES + +Functionality similar to this is implemented in +html/Elements/SetupSessionCookie ; however, that does not guarantee +that a session will be removed from disk and database soon after the +timeout expires. This script, if run from a cron job, will ensure +that the timed out sessions are actually removed from disk; the Mason +component just ensures that the old sessions are not reusable before +the cron job gets to them. + +=cut diff --git a/rt/sbin/rt-dump-database b/rt/sbin/rt-dump-database index 647781d..6175a10 100755 --- a/rt/sbin/rt-dump-database +++ b/rt/sbin/rt-dump-database @@ -2,8 +2,8 @@ # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -48,8 +48,30 @@ # END BPS TAGGED BLOCK }}} use strict; -use lib "/opt/rt3/local/lib"; -use lib "/opt/rt3/lib"; +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} use RT; use XML::Simple; @@ -117,7 +139,7 @@ foreach my $class (@classes) { # next if $obj-> # skip default names foreach my $field (sort keys %fields) { my $value = $obj->__Value($field); - $rv->{$field} = $value if length($value); + $rv->{$field} = $value if ( defined ($value) && length($value) ); } delete $rv->{Disabled} unless $rv->{Disabled}; diff --git a/rt/sbin/rt-dump-database.in b/rt/sbin/rt-dump-database.in index 10670a2..878a209 100755 --- a/rt/sbin/rt-dump-database.in +++ b/rt/sbin/rt-dump-database.in @@ -2,8 +2,8 @@ # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -48,8 +48,30 @@ # END BPS TAGGED BLOCK }}} use strict; -use lib "@LOCAL_LIB_PATH@"; -use lib "@RT_LIB_PATH@"; +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} use RT; use XML::Simple; @@ -117,7 +139,7 @@ foreach my $class (@classes) { # next if $obj-> # skip default names foreach my $field (sort keys %fields) { my $value = $obj->__Value($field); - $rv->{$field} = $value if length($value); + $rv->{$field} = $value if ( defined ($value) && length($value) ); } delete $rv->{Disabled} unless $rv->{Disabled}; diff --git a/rt/sbin/rt-email-dashboards b/rt/sbin/rt-email-dashboards new file mode 100755 index 0000000..d46e0fe --- /dev/null +++ b/rt/sbin/rt-email-dashboards @@ -0,0 +1,568 @@ +#!/usr/bin/perl +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use warnings; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use RT; +use RT::Interface::Web; +use RT::Interface::Web::Handler; +use RT::Dashboard; +use RT::Interface::CLI qw{ CleanEnv loc }; + +use Getopt::Long; +use HTML::Mason; +use HTML::RewriteAttributes::Resources; +use HTML::RewriteAttributes::Links; +use MIME::Types; +use POSIX 'tzset'; +use File::Temp 'tempdir'; + +# Clean out all the nasties from the environment +CleanEnv(); + +# Load the config file +RT::LoadConfig(); + +# Connect to the database and get RT::SystemUser and RT::Nobody loaded +RT::Init(); + +$HTML::Mason::Commands::r = RT::Dashboard::FakeRequest->new; + +no warnings 'once'; + +# Read in the options +my %opts; +GetOptions( \%opts, + "help", "dryrun", "verbose", "debug", "epoch=i", "all", "skip-acl" +); + +if ($opts{'help'}) { + require Pod::Usage; + import Pod::Usage; + pod2usage(-message => "RT Email Dashboards\n", -verbose => 1); + exit 1; +} + +# helper functions +sub verbose { print loc(@_), "\n" if $opts{debug} || $opts{verbose}; 1 } +sub debug { print loc(@_), "\n" if $opts{debug}; 1 } +sub error { $RT::Logger->error(loc(@_)); verbose(@_); 1 } +sub warning { $RT::Logger->warning(loc(@_)); verbose(@_); 1 } + +my $now = $opts{epoch} || time; +verbose "Using time [_1]", scalar localtime($now); + +my $from = get_from(); +debug "Sending email from [_1]", $from; + +# look through each user for her subscriptions +my $Users = RT::Users->new($RT::SystemUser); +$Users->LimitToPrivileged; + +while (defined(my $user = $Users->Next)) { + if ($user->PrincipalObj->Disabled) { + debug "Skipping over " + . $user->Name + . " due to having a disabled account."; + next; + } + + my ($hour, $dow, $dom) = hour_dow_dom_in($user->Timezone || RT->Config->Get('Timezone')); + $hour .= ':00'; + debug "Checking [_1]'s subscriptions: hour [_2], dow [_3], dom [_4]", + $user->Name, $hour, $dow, $dom; + + my $currentuser = RT::CurrentUser->new; + $currentuser->LoadByName($user->Name); + + # look through this user's subscriptions, are any supposed to be generated + # right now? + for my $subscription ($user->Attributes->Named('Subscription')) { + my $counter = $subscription->SubValue('Counter') || 0; + + if (!$opts{all}) { + debug "Checking against subscription with frequency [_1], hour [_2], dow [_3], dom [_4]", + $subscription->SubValue('Frequency'), $subscription->SubValue('Hour'), + $subscription->SubValue('Dow'), $subscription->SubValue('Dom'); + + next if $subscription->SubValue('Frequency') eq 'never'; + + # correct hour? + next if $subscription->SubValue('Hour') ne $hour; + + # if weekly, correct day of week? + if ( $subscription->SubValue('Frequency') eq 'weekly' ) { + next if $subscription->SubValue('Dow') ne $dow; + my $fow = $subscription->SubValue('Fow') || 1; + if ( $counter % $fow ) { + $subscription->SetSubValues( Counter => $counter + 1 ) + unless $opts{'dryrun'}; + next; + } + } + + # if monthly, correct day of month? + elsif ($subscription->SubValue('Frequency') eq 'monthly') { + next if $subscription->SubValue('Dom') != $dom; + } + + elsif ($subscription->SubValue('Frequency') eq 'm-f') { + next if $dow eq 'Sunday' || $dow eq 'Saturday'; + } + } + + my $email = $subscription->SubValue('Recipient') + || $user->EmailAddress; + + eval { send_dashboard($currentuser, $email, $subscription) }; + if ( $@ ) { + error 'Caught exception: ' . $@; + } + else { + $subscription->SetSubValues( + Counter => $counter + 1 ) + unless $opts{'dryrun'}; + } + } +} + +sub send_dashboard { + my ($currentuser, $email, $subscription) = @_; + + my $rows = $subscription->SubValue('Rows'); + + my $dashboard = RT::Dashboard->new($currentuser); + + my ($ok, $msg) = $dashboard->LoadById($subscription->SubValue('DashboardId')); + + # failed to load dashboard. perhaps it was deleted or it changed privacy + if (!$ok) { + warning "Unable to load dashboard [_1] of subscription [_2] for user [_3]: [_4]", + $subscription->SubValue('DashboardId'), + $subscription->Id, + $currentuser->Name, + $msg; + + my $ok = RT::Interface::Email::SendEmailUsingTemplate( + From => $from, + To => $email, + Template => 'Error: Missing dashboard', + Arguments => { + SubscriptionObj => $subscription, + }, + ); + + # only delete the subscription if the email looks like it went through + if ($ok) { + my ($deleted, $msg) = $subscription->Delete(); + if ($deleted) { + verbose("Deleted an obsolete subscription: [_1]", $msg); + } + else { + warning("Unable to delete an obsolete subscription: [_1]", $msg); + } + } + else { + warning("Unable to notify [_1] of an obsolete subscription", $currentuser->Name); + } + + return; + } + + verbose 'Creating dashboard "[_1]" for user "[_2]":', + $dashboard->Name, + $currentuser->Name; + + if ($opts{'dryrun'}) { + print << "SUMMARY"; + Dashboard: @{[ $dashboard->Name ]} + User: @{[ $currentuser->Name ]} <$email> +SUMMARY + return; + } + + $HTML::Mason::Commands::session{CurrentUser} = $currentuser; + my $contents = run_component( + '/Dashboards/Render.html', + id => $dashboard->Id, + Preview => 0, + ); + + for (@{ RT->Config->Get('EmailDashboardRemove') || [] }) { + $contents =~ s/$_//g; + } + + debug "Got [_1] characters of output.", length $contents; + + $contents = HTML::RewriteAttributes::Links->rewrite( + $contents, + RT->Config->Get('WebURL') . '/Dashboards/Render.html', + ); + + email_dashboard($currentuser, $email, $dashboard, $subscription, $contents); +} + +sub email_dashboard { + my ($currentuser, $email, $dashboard, $subscription, $content) = @_; + + verbose 'Sending dashboard "[_1]" to user [_2] <[_3]>', + $dashboard->Name, + $currentuser->Name, + $email; + + my $subject = sprintf '[%s] ' . RT->Config->Get('DashboardSubject'), + RT->Config->Get('rtname'), + ucfirst($subscription->SubValue('Frequency')), + $dashboard->Name; + + my $entity = build_email($content, $from, $email, $subject); + + my $ok = RT::Interface::Email::SendEmail( + Entity => $entity, + ); + + debug "Done sending dashboard to [_1] <[_2]>", + $currentuser->Name, $email + and return if $ok; + + error 'Failed to email dashboard to user [_1] <[_2]>', + $currentuser->Name, $email; +} + +sub build_email { + my ($content, $from, $to, $subject) = @_; + my @parts; + my %cid_of; + + $content = HTML::RewriteAttributes::Resources->rewrite($content, sub { + my $uri = shift; + + # already attached this object + return "cid:$cid_of{$uri}" if $cid_of{$uri}; + + $cid_of{$uri} = time() . $$ . int(rand(1e6)); + my ($data, $filename, $mimetype, $encoding) = get_resource($uri); + + # downgrade non-text strings, because all strings are utf8 by + # default, which is wrong for non-text strings. + if ( $mimetype !~ m{text/} ) { + utf8::downgrade( $data, 1 ) or warning "downgrade $data failed"; + } + + push @parts, MIME::Entity->build( + Top => 0, + Data => $data, + Type => $mimetype, + Encoding => $encoding, + Disposition => 'inline', + Name => $filename, + 'Content-Id' => $cid_of{$uri}, + ); + + return "cid:$cid_of{$uri}"; + }, + inline_css => sub { + my $uri = shift; + my ($content) = get_resource($uri); + return $content; + }, + inline_imports => 1, + ); + + my $entity = MIME::Entity->build( + From => $from, + To => $to, + Subject => $subject, + Type => "multipart/mixed", + ); + + $entity->attach( + Data => Encode::encode_utf8($content), + Type => 'text/html', + Charset => 'UTF-8', + Disposition => 'inline', + ); + + for my $part (@parts) { + $entity->add_part($part); + } + + return $entity; +} + +sub get_from { + RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail') +} + +{ + my $mason; + my $outbuf = ''; + my $data_dir = ''; + + sub mason { + unless ($mason) { + debug "Creating Mason object."; + + # user may not have permissions on the data directory, so create a + # new one + $data_dir = tempdir(CLEANUP => 1); + + $mason = HTML::Mason::Interp->new( + RT::Interface::Web::Handler->DefaultHandlerArgs, + out_method => \$outbuf, + autohandler_name => '', # disable forced login and more + data_dir => $data_dir, + ); + } + return $mason; + } + + sub run_component { + mason->exec(@_); + my $ret = $outbuf; + $outbuf = ''; + return $ret; + } +} + +{ + my %cache; + + sub hour_dow_dom_in { + my $tz = shift; + return @{$cache{$tz}} if exists $cache{$tz}; + + my ($hour, $dow, $dom); + + { + local $ENV{'TZ'} = $tz; + ## Using POSIX::tzset fixes a bug where the TZ environment variable + ## is cached. + tzset(); + (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now); + } + tzset(); # return back previous value + + $hour = "0$hour" + if length($hour) == 1; + $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow]; + + return @{$cache{$tz}} = ($hour, $dow, $dom); + } +} + +sub get_resource { + my $uri = URI->new(shift); + my ($content, $filename, $mimetype, $encoding); + + verbose "Getting resource [_1]", $uri; + + # strip out the equivalent of WebURL, so we start at the correct / + my $path = $uri->path; + my $webpath = RT->Config->Get('WebPath'); + $path =~ s/^\Q$webpath//; + + # add a leading / if needed + $path = "/$path" + unless $path =~ m{^/}; + + # grab the query arguments + my %args; + for (split /&/, ($uri->query||'')) { + my ($k, $v) = /^(.*?)=(.*)$/ + or die "Unable to parse query parameter '$_'"; + + for ($k, $v) { s/%(..)/chr hex $1/ge } + + # no value yet, simple key=value + if (!exists $args{$k}) { + $args{$k} = $v; + } + # already have key=value, need to upgrade it to key=[value1, value2] + elsif (!ref($args{$k})) { + $args{$k} = [$args{$k}, $v]; + } + # already key=[value1, value2], just add the new value + else { + push @{ $args{$k} }, $v; + } + } + + debug "Running component '[_1]'", $path; + $content = run_component($path, %args); + + # guess at the filename from the component name + $filename = $1 if $path =~ m{^.*/(.*?)$}; + + # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP + ($mimetype, $encoding) = MIME::Types::by_suffix($filename); + + my $content_type = $HTML::Mason::Commands::r->content_type; + if ($content_type) { + $mimetype = $content_type; + + # strip down to just a MIME type + $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/; + } + + #If all else fails then some conservative and general-purpose defaults are: + $mimetype ||= 'application/octet-stream'; + $encoding ||= 'base64'; + + debug "Resource [_1]: length=[_2] filename='[_3]' mimetype='[_4]', encoding='[_5]'", + $uri, + length($content), + $filename, + $mimetype, + $encoding; + + return ($content, $filename, $mimetype, $encoding); +} + +package RT::Dashboard::FakeRequest; +sub new { bless {}, shift } +sub header_out { shift } +sub headers_out { shift } +sub content_type { + my $self = shift; + $self->{content_type} = shift if @_; + return $self->{content_type}; +} + +=head1 NAME + +rt-email-dashboards - Send email dashboards + +=head1 SYNOPSIS + + /opt/rt3/local/sbin/rt-email-dashboards [options] + +=head1 DESCRIPTION + +This tool will send users email based on how they have subscribed to +dashboards. A dashboard is a set of saved searches, the subscription controls +how often that dashboard is sent and how it's displayed. + +Each subscription has an hour, and possibly day of week or day of month. These +are taken to be in the user's timezone if available, UTC otherwise. + +=head1 SETUP + +You'll need to have cron run this script every hour. Here's an example crontab +entry to do this. + + 0 * * * * /usr/bin/perl /opt/rt3/local/sbin/rt-email-dashboards + +This will run the script every hour on the hour. This may need some further +tweaking to be run as the correct user. + +=head1 OPTIONS + +This tool supports a few options. Most are for debugging. + +=over 8 + +=item --help + +Display this documentation + +=item --dryrun + +Figure out which dashboards would be sent, but don't actually generate them + +=item --epoch SECONDS + +Instead of using the current time to figure out which dashboards should be +sent, use SECONDS (usually since midnight Jan 1st, 1970, so C<1192216018> would +be Oct 12 19:06:58 GMT 2007). + +=item --verbose + +Print out some tracing information (such as which dashboards are being +generated and sent out) + +=item --debug + +Print out more tracing information (such as each user and subscription that is +being considered) + +=item --all + +Ignore subscription frequency when considering each dashboard (should only be +used with --dryrun) + +=back + +=cut + diff --git a/rt/sbin/rt-email-dashboards.in b/rt/sbin/rt-email-dashboards.in new file mode 100644 index 0000000..5565435 --- /dev/null +++ b/rt/sbin/rt-email-dashboards.in @@ -0,0 +1,568 @@ +#!@PERL@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use warnings; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use RT; +use RT::Interface::Web; +use RT::Interface::Web::Handler; +use RT::Dashboard; +use RT::Interface::CLI qw{ CleanEnv loc }; + +use Getopt::Long; +use HTML::Mason; +use HTML::RewriteAttributes::Resources; +use HTML::RewriteAttributes::Links; +use MIME::Types; +use POSIX 'tzset'; +use File::Temp 'tempdir'; + +# Clean out all the nasties from the environment +CleanEnv(); + +# Load the config file +RT::LoadConfig(); + +# Connect to the database and get RT::SystemUser and RT::Nobody loaded +RT::Init(); + +$HTML::Mason::Commands::r = RT::Dashboard::FakeRequest->new; + +no warnings 'once'; + +# Read in the options +my %opts; +GetOptions( \%opts, + "help", "dryrun", "verbose", "debug", "epoch=i", "all", "skip-acl" +); + +if ($opts{'help'}) { + require Pod::Usage; + import Pod::Usage; + pod2usage(-message => "RT Email Dashboards\n", -verbose => 1); + exit 1; +} + +# helper functions +sub verbose { print loc(@_), "\n" if $opts{debug} || $opts{verbose}; 1 } +sub debug { print loc(@_), "\n" if $opts{debug}; 1 } +sub error { $RT::Logger->error(loc(@_)); verbose(@_); 1 } +sub warning { $RT::Logger->warning(loc(@_)); verbose(@_); 1 } + +my $now = $opts{epoch} || time; +verbose "Using time [_1]", scalar localtime($now); + +my $from = get_from(); +debug "Sending email from [_1]", $from; + +# look through each user for her subscriptions +my $Users = RT::Users->new($RT::SystemUser); +$Users->LimitToPrivileged; + +while (defined(my $user = $Users->Next)) { + if ($user->PrincipalObj->Disabled) { + debug "Skipping over " + . $user->Name + . " due to having a disabled account."; + next; + } + + my ($hour, $dow, $dom) = hour_dow_dom_in($user->Timezone || RT->Config->Get('Timezone')); + $hour .= ':00'; + debug "Checking [_1]'s subscriptions: hour [_2], dow [_3], dom [_4]", + $user->Name, $hour, $dow, $dom; + + my $currentuser = RT::CurrentUser->new; + $currentuser->LoadByName($user->Name); + + # look through this user's subscriptions, are any supposed to be generated + # right now? + for my $subscription ($user->Attributes->Named('Subscription')) { + my $counter = $subscription->SubValue('Counter') || 0; + + if (!$opts{all}) { + debug "Checking against subscription with frequency [_1], hour [_2], dow [_3], dom [_4]", + $subscription->SubValue('Frequency'), $subscription->SubValue('Hour'), + $subscription->SubValue('Dow'), $subscription->SubValue('Dom'); + + next if $subscription->SubValue('Frequency') eq 'never'; + + # correct hour? + next if $subscription->SubValue('Hour') ne $hour; + + # if weekly, correct day of week? + if ( $subscription->SubValue('Frequency') eq 'weekly' ) { + next if $subscription->SubValue('Dow') ne $dow; + my $fow = $subscription->SubValue('Fow') || 1; + if ( $counter % $fow ) { + $subscription->SetSubValues( Counter => $counter + 1 ) + unless $opts{'dryrun'}; + next; + } + } + + # if monthly, correct day of month? + elsif ($subscription->SubValue('Frequency') eq 'monthly') { + next if $subscription->SubValue('Dom') != $dom; + } + + elsif ($subscription->SubValue('Frequency') eq 'm-f') { + next if $dow eq 'Sunday' || $dow eq 'Saturday'; + } + } + + my $email = $subscription->SubValue('Recipient') + || $user->EmailAddress; + + eval { send_dashboard($currentuser, $email, $subscription) }; + if ( $@ ) { + error 'Caught exception: ' . $@; + } + else { + $subscription->SetSubValues( + Counter => $counter + 1 ) + unless $opts{'dryrun'}; + } + } +} + +sub send_dashboard { + my ($currentuser, $email, $subscription) = @_; + + my $rows = $subscription->SubValue('Rows'); + + my $dashboard = RT::Dashboard->new($currentuser); + + my ($ok, $msg) = $dashboard->LoadById($subscription->SubValue('DashboardId')); + + # failed to load dashboard. perhaps it was deleted or it changed privacy + if (!$ok) { + warning "Unable to load dashboard [_1] of subscription [_2] for user [_3]: [_4]", + $subscription->SubValue('DashboardId'), + $subscription->Id, + $currentuser->Name, + $msg; + + my $ok = RT::Interface::Email::SendEmailUsingTemplate( + From => $from, + To => $email, + Template => 'Error: Missing dashboard', + Arguments => { + SubscriptionObj => $subscription, + }, + ); + + # only delete the subscription if the email looks like it went through + if ($ok) { + my ($deleted, $msg) = $subscription->Delete(); + if ($deleted) { + verbose("Deleted an obsolete subscription: [_1]", $msg); + } + else { + warning("Unable to delete an obsolete subscription: [_1]", $msg); + } + } + else { + warning("Unable to notify [_1] of an obsolete subscription", $currentuser->Name); + } + + return; + } + + verbose 'Creating dashboard "[_1]" for user "[_2]":', + $dashboard->Name, + $currentuser->Name; + + if ($opts{'dryrun'}) { + print << "SUMMARY"; + Dashboard: @{[ $dashboard->Name ]} + User: @{[ $currentuser->Name ]} <$email> +SUMMARY + return; + } + + $HTML::Mason::Commands::session{CurrentUser} = $currentuser; + my $contents = run_component( + '/Dashboards/Render.html', + id => $dashboard->Id, + Preview => 0, + ); + + for (@{ RT->Config->Get('EmailDashboardRemove') || [] }) { + $contents =~ s/$_//g; + } + + debug "Got [_1] characters of output.", length $contents; + + $contents = HTML::RewriteAttributes::Links->rewrite( + $contents, + RT->Config->Get('WebURL') . '/Dashboards/Render.html', + ); + + email_dashboard($currentuser, $email, $dashboard, $subscription, $contents); +} + +sub email_dashboard { + my ($currentuser, $email, $dashboard, $subscription, $content) = @_; + + verbose 'Sending dashboard "[_1]" to user [_2] <[_3]>', + $dashboard->Name, + $currentuser->Name, + $email; + + my $subject = sprintf '[%s] ' . RT->Config->Get('DashboardSubject'), + RT->Config->Get('rtname'), + ucfirst($subscription->SubValue('Frequency')), + $dashboard->Name; + + my $entity = build_email($content, $from, $email, $subject); + + my $ok = RT::Interface::Email::SendEmail( + Entity => $entity, + ); + + debug "Done sending dashboard to [_1] <[_2]>", + $currentuser->Name, $email + and return if $ok; + + error 'Failed to email dashboard to user [_1] <[_2]>', + $currentuser->Name, $email; +} + +sub build_email { + my ($content, $from, $to, $subject) = @_; + my @parts; + my %cid_of; + + $content = HTML::RewriteAttributes::Resources->rewrite($content, sub { + my $uri = shift; + + # already attached this object + return "cid:$cid_of{$uri}" if $cid_of{$uri}; + + $cid_of{$uri} = time() . $$ . int(rand(1e6)); + my ($data, $filename, $mimetype, $encoding) = get_resource($uri); + + # downgrade non-text strings, because all strings are utf8 by + # default, which is wrong for non-text strings. + if ( $mimetype !~ m{text/} ) { + utf8::downgrade( $data, 1 ) or warning "downgrade $data failed"; + } + + push @parts, MIME::Entity->build( + Top => 0, + Data => $data, + Type => $mimetype, + Encoding => $encoding, + Disposition => 'inline', + Name => $filename, + 'Content-Id' => $cid_of{$uri}, + ); + + return "cid:$cid_of{$uri}"; + }, + inline_css => sub { + my $uri = shift; + my ($content) = get_resource($uri); + return $content; + }, + inline_imports => 1, + ); + + my $entity = MIME::Entity->build( + From => $from, + To => $to, + Subject => $subject, + Type => "multipart/mixed", + ); + + $entity->attach( + Data => Encode::encode_utf8($content), + Type => 'text/html', + Charset => 'UTF-8', + Disposition => 'inline', + ); + + for my $part (@parts) { + $entity->add_part($part); + } + + return $entity; +} + +sub get_from { + RT->Config->Get('DashboardAddress') || RT->Config->Get('OwnerEmail') +} + +{ + my $mason; + my $outbuf = ''; + my $data_dir = ''; + + sub mason { + unless ($mason) { + debug "Creating Mason object."; + + # user may not have permissions on the data directory, so create a + # new one + $data_dir = tempdir(CLEANUP => 1); + + $mason = HTML::Mason::Interp->new( + RT::Interface::Web::Handler->DefaultHandlerArgs, + out_method => \$outbuf, + autohandler_name => '', # disable forced login and more + data_dir => $data_dir, + ); + } + return $mason; + } + + sub run_component { + mason->exec(@_); + my $ret = $outbuf; + $outbuf = ''; + return $ret; + } +} + +{ + my %cache; + + sub hour_dow_dom_in { + my $tz = shift; + return @{$cache{$tz}} if exists $cache{$tz}; + + my ($hour, $dow, $dom); + + { + local $ENV{'TZ'} = $tz; + ## Using POSIX::tzset fixes a bug where the TZ environment variable + ## is cached. + tzset(); + (undef, undef, $hour, $dom, undef, undef, $dow) = localtime($now); + } + tzset(); # return back previous value + + $hour = "0$hour" + if length($hour) == 1; + $dow = (qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/)[$dow]; + + return @{$cache{$tz}} = ($hour, $dow, $dom); + } +} + +sub get_resource { + my $uri = URI->new(shift); + my ($content, $filename, $mimetype, $encoding); + + verbose "Getting resource [_1]", $uri; + + # strip out the equivalent of WebURL, so we start at the correct / + my $path = $uri->path; + my $webpath = RT->Config->Get('WebPath'); + $path =~ s/^\Q$webpath//; + + # add a leading / if needed + $path = "/$path" + unless $path =~ m{^/}; + + # grab the query arguments + my %args; + for (split /&/, ($uri->query||'')) { + my ($k, $v) = /^(.*?)=(.*)$/ + or die "Unable to parse query parameter '$_'"; + + for ($k, $v) { s/%(..)/chr hex $1/ge } + + # no value yet, simple key=value + if (!exists $args{$k}) { + $args{$k} = $v; + } + # already have key=value, need to upgrade it to key=[value1, value2] + elsif (!ref($args{$k})) { + $args{$k} = [$args{$k}, $v]; + } + # already key=[value1, value2], just add the new value + else { + push @{ $args{$k} }, $v; + } + } + + debug "Running component '[_1]'", $path; + $content = run_component($path, %args); + + # guess at the filename from the component name + $filename = $1 if $path =~ m{^.*/(.*?)$}; + + # the rest of this was taken from Email::MIME::CreateHTML::Resolver::LWP + ($mimetype, $encoding) = MIME::Types::by_suffix($filename); + + my $content_type = $HTML::Mason::Commands::r->content_type; + if ($content_type) { + $mimetype = $content_type; + + # strip down to just a MIME type + $mimetype = $1 if $mimetype =~ /(\S+);\s*charset=(.*)$/; + } + + #If all else fails then some conservative and general-purpose defaults are: + $mimetype ||= 'application/octet-stream'; + $encoding ||= 'base64'; + + debug "Resource [_1]: length=[_2] filename='[_3]' mimetype='[_4]', encoding='[_5]'", + $uri, + length($content), + $filename, + $mimetype, + $encoding; + + return ($content, $filename, $mimetype, $encoding); +} + +package RT::Dashboard::FakeRequest; +sub new { bless {}, shift } +sub header_out { shift } +sub headers_out { shift } +sub content_type { + my $self = shift; + $self->{content_type} = shift if @_; + return $self->{content_type}; +} + +=head1 NAME + +rt-email-dashboards - Send email dashboards + +=head1 SYNOPSIS + + /opt/rt3/local/sbin/rt-email-dashboards [options] + +=head1 DESCRIPTION + +This tool will send users email based on how they have subscribed to +dashboards. A dashboard is a set of saved searches, the subscription controls +how often that dashboard is sent and how it's displayed. + +Each subscription has an hour, and possibly day of week or day of month. These +are taken to be in the user's timezone if available, UTC otherwise. + +=head1 SETUP + +You'll need to have cron run this script every hour. Here's an example crontab +entry to do this. + + 0 * * * * @PERL@ /opt/rt3/local/sbin/rt-email-dashboards + +This will run the script every hour on the hour. This may need some further +tweaking to be run as the correct user. + +=head1 OPTIONS + +This tool supports a few options. Most are for debugging. + +=over 8 + +=item --help + +Display this documentation + +=item --dryrun + +Figure out which dashboards would be sent, but don't actually generate them + +=item --epoch SECONDS + +Instead of using the current time to figure out which dashboards should be +sent, use SECONDS (usually since midnight Jan 1st, 1970, so C<1192216018> would +be Oct 12 19:06:58 GMT 2007). + +=item --verbose + +Print out some tracing information (such as which dashboards are being +generated and sent out) + +=item --debug + +Print out more tracing information (such as each user and subscription that is +being considered) + +=item --all + +Ignore subscription frequency when considering each dashboard (should only be +used with --dryrun) + +=back + +=cut + diff --git a/rt/sbin/rt-email-digest b/rt/sbin/rt-email-digest new file mode 100755 index 0000000..29ee1cb --- /dev/null +++ b/rt/sbin/rt-email-digest @@ -0,0 +1,337 @@ +#!/usr/bin/perl +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use warnings; +use strict; + +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use Date::Format qw( strftime ); +use Getopt::Long; +use RT; +use RT::Interface::CLI qw( CleanEnv loc ); +use RT::Interface::Email; + +CleanEnv(); +RT::LoadConfig(); +RT::Init(); + +sub usage { + my ($error) = @_; + print loc("Usage: ") . "$0 -m (daily|weekly) [--print] [--help]\n"; + print loc( + "[_1] is a utility, meant to be run from cron, that dispatches all deferred RT notifications as a per-user digest.", + $0 + ) . "\n"; + print "\n\t-m, --mode\t" + . loc("Specify whether this is a daily or weekly run.") . "\n"; + print "\t-p, --print\t" + . loc("Print the resulting digest messages to STDOUT; don't mail them. Do not mark them as sent") + . "\n"; + print "\t-h, --help\t" . loc("Print this message") . "\n"; + + if ( $error eq 'help' ) { + exit 0; + } else { + print loc("Error") . ": " . loc($error) . "\n"; + exit 1; + } +} + +my ( $frequency, $print, $help ) = ( '', '', '' ); +GetOptions( + 'mode=s' => \$frequency, + 'print' => \$print, + 'help' => \$help, +); + +usage('help') if $help; +usage("Mode argument must be 'daily' or 'weekly'") + unless $frequency =~ /^(daily|weekly)$/; + +run( $frequency, $print ); + +sub run { + my $frequency = shift; + my $print = shift; + +## Find all the tickets that have been modified within the time frame +## described by $frequency. + + my ( $all_digest, $sent_transactions ) = find_transactions($frequency); + +## Iterate through our huge hash constructing the digest message +## for each user and sending it. + + foreach my $user ( keys %$all_digest ) { + my ( $contents_list, $contents_body ) = build_digest_for_user( $user, $all_digest->{$user} ); + # Now we have a content head and a content body. We can send a message. + if ( send_digest( $user, $contents_list, $contents_body ) ) { + print "Sent message to $user\n"; + mark_transactions_sent( $frequency, $user, values %{$sent_transactions->{$user}} ) unless ($print); + } else { + print "Failed to send message to $user\n"; + } + } +} +exit 0; + +# Subroutines. + +sub send_digest { + my ( $to, $index, $messages ) = @_; + + # Combine the index and the messages. + + my $body = "============== Tickets with activity in the last " + . ( $frequency eq 'daily' ? "day" : "seven days" ) . "\n\n"; + + $body .= $index; + $body .= "\n\n============== Messages recorded in the last " + . ( $frequency eq 'daily' ? "day" : "seven days" ) . "\n\n"; + $body .= $messages; + + # Load our template. If we cannot load the template, abort + # immediately rather than failing through many loops. + my $digest_template = RT::Template->new( RT->SystemUser ); + my ( $ret, $msg ) = $digest_template->Load('Email Digest'); + unless ($ret) { + print loc("Failed to load template") + . " 'Email Digest': " + . $msg + . ". Cannot continue.\n"; + exit 1; + } + ( $ret, $msg ) = $digest_template->Parse( Argument => $body ); + unless ($ret) { + print loc("Failed to parse template") + . " 'Email Digest'. Cannot continue.\n"; + exit 1; + } + + # Set our sender and recipient. + $digest_template->MIMEObj->head->replace( 'From', RT::Config->Get('CorrespondAddress') ); + $digest_template->MIMEObj->head->replace( 'To', $to ); + + if ($print) { + $digest_template->MIMEObj->print; + return 1; + } else { + return RT::Interface::Email::SendEmail( Entity => $digest_template->MIMEObj) + } +} + +=item mark_transactions_sent( $frequency, $user, @txn_list ); + +Takes a frequency string (either 'daily' or 'weekly'), a user and one or more +transaction objects as its arguments. Marks the given deferred +notifications as sent. + +=cut + +sub mark_transactions_sent { + my ( $freq, $user, @txns ) = @_; + return unless $freq =~ /(daily|weekly)/; + return unless @txns; + foreach my $txn (@txns) { + + # Grab the attribute, mark the "sent" as true, and store the new + # value. + if ( my $attr = $txn->FirstAttribute('DeferredRecipients') ) { + my $deferred = $attr->Content; + $deferred->{$freq}->{$user}->{'_sent'} = 1; + $txn->SetAttribute( + Name => 'DeferredRecipients', + Description => 'Deferred recipients for this message', + Content => $deferred, + ); + } + } +} + +sub since_date { + my $frequency = shift; + + # Specify a short time for digest overlap, in case we aren't starting + # this process exactly on time. + my $OVERLAP_HEDGE = -30; + + my $since_date = RT::Date->new( RT->SystemUser ); + $since_date->Set( Format => 'unix', Value => time() ); + if ( $frequency eq 'daily' ) { + $since_date->AddDays(-1); + } else { + $since_date->AddDays(-7); + } + + $since_date->AddSeconds($OVERLAP_HEDGE); + + return $since_date; +} + +sub find_transactions { + my $frequency = shift; + my $since_date = since_date($frequency); + + my $txns = RT::Transactions->new( RT->SystemUser ); + + # First limit to recent transactions. + $txns->Limit( + FIELD => 'Created', + OPERATOR => '>', + VALUE => $since_date->ISO + ); + + # Next limit to ticket transactions. + $txns->Limit( + FIELD => 'ObjectType', + OPERATOR => '=', + VALUE => 'RT::Ticket', + ENTRYAGGREGATOR => 'AND' + ); + my $all_digest = {}; + my $sent_transactions = {}; + + while ( my $txn = $txns->Next ) { + my $ticket = $txn->Ticket; + my $queue = $txn->TicketObj->QueueObj->Name; + # Xxx todo - may clobber if two queues have the same name + foreach my $user ( $txn->DeferredRecipients($frequency) ) { + $all_digest->{$user}->{$queue}->{$ticket}->{ $txn->id } = $txn->ContentObj; + $sent_transactions->{$user}->{ $txn->id } = $txn; + } + } + + return ( $all_digest, $sent_transactions ); +} + +sub build_digest_for_user { + my $user = shift; + my $user_digest = shift; + + my $contents_list = ''; # Holds the digest index. + my $contents_body = ''; # Holds the digest body. + + # Has the user been disabled since a message was deferred on his/her + # behalf? + my $user_obj = RT::User->new( RT->SystemUser ); + $user_obj->LoadByEmail($user); + if ( $user_obj->PrincipalObj->Disabled ) { + print STDERR loc("Skipping disabled user") . " $user\n"; + next; + } + + print loc("Message for user") . " $user:\n\n" if $print; + foreach my $queue ( keys %$user_digest ) { + $contents_list .= "Queue $queue:\n"; + $contents_body .= "Queue $queue:\n"; + foreach my $ticket ( sort keys %{ $user_digest->{$queue} } ) { + my $tkt_txns = $user_digest->{$queue}->{$ticket}; + my $ticket_obj = RT::Ticket->new( RT->SystemUser ); + $ticket_obj->Load($ticket); + + # Spit out the index entry for this ticket. + my $ticket_title = sprintf( + "#%d %s [%s]\t%s\n", + $ticket, $ticket_obj->Status, $ticket_obj->OwnerObj->Name, + $ticket_obj->Subject + ); + $contents_list .= $ticket_title; + + # Spit out the messages for the transactions on this ticket. + $contents_body .= "\n== $ticket_title\n"; + foreach my $txn ( sort keys %$tkt_txns ) { + my $msg = $tkt_txns->{$txn}; + + # $msg contains an RT::Attachment with our outgoing + # message. Print a few headers for clarity's sake. + $contents_body .= "From: " . $msg->GetHeader('From') . "\n"; + my $date = $msg->GetHeader('Date '); + unless ($date) { + my $txn_obj = RT::Transaction->new( RT->SystemUser ); + $txn_obj->Load($txn); + my $date_obj = RT::Date->new( RT->SystemUser ); + $date_obj->Set( + Format => 'sql', + Value => $txn_obj->Created + ); + $date = strftime( '%a, %d %b %Y %H:%M:%S %z', + @{ [ localtime( $date_obj->Unix ) ] } ); + } + $contents_body .= "Date: $date\n\n"; + $contents_body .= $msg->Content . "\n"; + $contents_body .= "-------\n"; + } # foreach transaction + } # foreach ticket + } # foreach queue + + return ( $contents_list, $contents_body ); + +} diff --git a/rt/sbin/rt-email-digest.in b/rt/sbin/rt-email-digest.in new file mode 100644 index 0000000..2fc7c00 --- /dev/null +++ b/rt/sbin/rt-email-digest.in @@ -0,0 +1,337 @@ +#!@PERL@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use warnings; +use strict; + +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use Date::Format qw( strftime ); +use Getopt::Long; +use RT; +use RT::Interface::CLI qw( CleanEnv loc ); +use RT::Interface::Email; + +CleanEnv(); +RT::LoadConfig(); +RT::Init(); + +sub usage { + my ($error) = @_; + print loc("Usage: ") . "$0 -m (daily|weekly) [--print] [--help]\n"; + print loc( + "[_1] is a utility, meant to be run from cron, that dispatches all deferred RT notifications as a per-user digest.", + $0 + ) . "\n"; + print "\n\t-m, --mode\t" + . loc("Specify whether this is a daily or weekly run.") . "\n"; + print "\t-p, --print\t" + . loc("Print the resulting digest messages to STDOUT; don't mail them. Do not mark them as sent") + . "\n"; + print "\t-h, --help\t" . loc("Print this message") . "\n"; + + if ( $error eq 'help' ) { + exit 0; + } else { + print loc("Error") . ": " . loc($error) . "\n"; + exit 1; + } +} + +my ( $frequency, $print, $help ) = ( '', '', '' ); +GetOptions( + 'mode=s' => \$frequency, + 'print' => \$print, + 'help' => \$help, +); + +usage('help') if $help; +usage("Mode argument must be 'daily' or 'weekly'") + unless $frequency =~ /^(daily|weekly)$/; + +run( $frequency, $print ); + +sub run { + my $frequency = shift; + my $print = shift; + +## Find all the tickets that have been modified within the time frame +## described by $frequency. + + my ( $all_digest, $sent_transactions ) = find_transactions($frequency); + +## Iterate through our huge hash constructing the digest message +## for each user and sending it. + + foreach my $user ( keys %$all_digest ) { + my ( $contents_list, $contents_body ) = build_digest_for_user( $user, $all_digest->{$user} ); + # Now we have a content head and a content body. We can send a message. + if ( send_digest( $user, $contents_list, $contents_body ) ) { + print "Sent message to $user\n"; + mark_transactions_sent( $frequency, $user, values %{$sent_transactions->{$user}} ) unless ($print); + } else { + print "Failed to send message to $user\n"; + } + } +} +exit 0; + +# Subroutines. + +sub send_digest { + my ( $to, $index, $messages ) = @_; + + # Combine the index and the messages. + + my $body = "============== Tickets with activity in the last " + . ( $frequency eq 'daily' ? "day" : "seven days" ) . "\n\n"; + + $body .= $index; + $body .= "\n\n============== Messages recorded in the last " + . ( $frequency eq 'daily' ? "day" : "seven days" ) . "\n\n"; + $body .= $messages; + + # Load our template. If we cannot load the template, abort + # immediately rather than failing through many loops. + my $digest_template = RT::Template->new( RT->SystemUser ); + my ( $ret, $msg ) = $digest_template->Load('Email Digest'); + unless ($ret) { + print loc("Failed to load template") + . " 'Email Digest': " + . $msg + . ". Cannot continue.\n"; + exit 1; + } + ( $ret, $msg ) = $digest_template->Parse( Argument => $body ); + unless ($ret) { + print loc("Failed to parse template") + . " 'Email Digest'. Cannot continue.\n"; + exit 1; + } + + # Set our sender and recipient. + $digest_template->MIMEObj->head->replace( 'From', RT::Config->Get('CorrespondAddress') ); + $digest_template->MIMEObj->head->replace( 'To', $to ); + + if ($print) { + $digest_template->MIMEObj->print; + return 1; + } else { + return RT::Interface::Email::SendEmail( Entity => $digest_template->MIMEObj) + } +} + +=item mark_transactions_sent( $frequency, $user, @txn_list ); + +Takes a frequency string (either 'daily' or 'weekly'), a user and one or more +transaction objects as its arguments. Marks the given deferred +notifications as sent. + +=cut + +sub mark_transactions_sent { + my ( $freq, $user, @txns ) = @_; + return unless $freq =~ /(daily|weekly)/; + return unless @txns; + foreach my $txn (@txns) { + + # Grab the attribute, mark the "sent" as true, and store the new + # value. + if ( my $attr = $txn->FirstAttribute('DeferredRecipients') ) { + my $deferred = $attr->Content; + $deferred->{$freq}->{$user}->{'_sent'} = 1; + $txn->SetAttribute( + Name => 'DeferredRecipients', + Description => 'Deferred recipients for this message', + Content => $deferred, + ); + } + } +} + +sub since_date { + my $frequency = shift; + + # Specify a short time for digest overlap, in case we aren't starting + # this process exactly on time. + my $OVERLAP_HEDGE = -30; + + my $since_date = RT::Date->new( RT->SystemUser ); + $since_date->Set( Format => 'unix', Value => time() ); + if ( $frequency eq 'daily' ) { + $since_date->AddDays(-1); + } else { + $since_date->AddDays(-7); + } + + $since_date->AddSeconds($OVERLAP_HEDGE); + + return $since_date; +} + +sub find_transactions { + my $frequency = shift; + my $since_date = since_date($frequency); + + my $txns = RT::Transactions->new( RT->SystemUser ); + + # First limit to recent transactions. + $txns->Limit( + FIELD => 'Created', + OPERATOR => '>', + VALUE => $since_date->ISO + ); + + # Next limit to ticket transactions. + $txns->Limit( + FIELD => 'ObjectType', + OPERATOR => '=', + VALUE => 'RT::Ticket', + ENTRYAGGREGATOR => 'AND' + ); + my $all_digest = {}; + my $sent_transactions = {}; + + while ( my $txn = $txns->Next ) { + my $ticket = $txn->Ticket; + my $queue = $txn->TicketObj->QueueObj->Name; + # Xxx todo - may clobber if two queues have the same name + foreach my $user ( $txn->DeferredRecipients($frequency) ) { + $all_digest->{$user}->{$queue}->{$ticket}->{ $txn->id } = $txn->ContentObj; + $sent_transactions->{$user}->{ $txn->id } = $txn; + } + } + + return ( $all_digest, $sent_transactions ); +} + +sub build_digest_for_user { + my $user = shift; + my $user_digest = shift; + + my $contents_list = ''; # Holds the digest index. + my $contents_body = ''; # Holds the digest body. + + # Has the user been disabled since a message was deferred on his/her + # behalf? + my $user_obj = RT::User->new( RT->SystemUser ); + $user_obj->LoadByEmail($user); + if ( $user_obj->PrincipalObj->Disabled ) { + print STDERR loc("Skipping disabled user") . " $user\n"; + next; + } + + print loc("Message for user") . " $user:\n\n" if $print; + foreach my $queue ( keys %$user_digest ) { + $contents_list .= "Queue $queue:\n"; + $contents_body .= "Queue $queue:\n"; + foreach my $ticket ( sort keys %{ $user_digest->{$queue} } ) { + my $tkt_txns = $user_digest->{$queue}->{$ticket}; + my $ticket_obj = RT::Ticket->new( RT->SystemUser ); + $ticket_obj->Load($ticket); + + # Spit out the index entry for this ticket. + my $ticket_title = sprintf( + "#%d %s [%s]\t%s\n", + $ticket, $ticket_obj->Status, $ticket_obj->OwnerObj->Name, + $ticket_obj->Subject + ); + $contents_list .= $ticket_title; + + # Spit out the messages for the transactions on this ticket. + $contents_body .= "\n== $ticket_title\n"; + foreach my $txn ( sort keys %$tkt_txns ) { + my $msg = $tkt_txns->{$txn}; + + # $msg contains an RT::Attachment with our outgoing + # message. Print a few headers for clarity's sake. + $contents_body .= "From: " . $msg->GetHeader('From') . "\n"; + my $date = $msg->GetHeader('Date '); + unless ($date) { + my $txn_obj = RT::Transaction->new( RT->SystemUser ); + $txn_obj->Load($txn); + my $date_obj = RT::Date->new( RT->SystemUser ); + $date_obj->Set( + Format => 'sql', + Value => $txn_obj->Created + ); + $date = strftime( '%a, %d %b %Y %H:%M:%S %z', + @{ [ localtime( $date_obj->Unix ) ] } ); + } + $contents_body .= "Date: $date\n\n"; + $contents_body .= $msg->Content . "\n"; + $contents_body .= "-------\n"; + } # foreach transaction + } # foreach ticket + } # foreach queue + + return ( $contents_list, $contents_body ); + +} diff --git a/rt/sbin/rt-email-group-admin b/rt/sbin/rt-email-group-admin new file mode 100755 index 0000000..75b51a5 --- /dev/null +++ b/rt/sbin/rt-email-group-admin @@ -0,0 +1,508 @@ +#!/usr/bin/perl +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +=head1 NAME + +rt-email-group-admin - Command line tool for administrating NotifyGroup actions + +=head1 SYNOPSIS + + rt-email-group-admin --list + rt-email-group-admin --create 'Notify foo team' --group Foo + rt-email-group-admin --create 'Notify foo team as comment' --comment --group Foo + rt-email-group-admin --create 'Notify group Foo and Bar' --group Foo --group Bar + rt-email-group-admin --create 'Notify user foo@bar.com' --user foo@bar.com + rt-email-group-admin --create 'Notify VIPs' --user vip1@bar.com + rt-email-group-admin --add 'Notify VIPs' --user vip2@bar.com --group vip1 --user vip3@foo.com + rt-email-group-admin --rename 'Notify VIPs' --newname 'Inform VIPs' + rt-email-group-admin --switch 'Notify VIPs' + rt-email-group-admin --delete 'Notify user foo@bar.com' + +=head1 DESCRIPTION + +This script list, create, modify or delete scrip actions in the RT DB. Once +you've created an action you can use it in a scrip. + +For example you can create the following action using this script: + + rt-email-group-admin --create 'Notify developers' --group 'Development Team' + +Then you can add the followoing scrip to your Bugs queue: + + Condition: On Create + Action: Notify developers + Template: Transaction + Stage: TransactionCreate + +Your development team will be notified on every new ticket in the queue. + +=cut + +use warnings; +use strict; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use RT; +RT::LoadConfig; +RT::Init; + +require RT::Principal; +require RT::User; +require RT::Group; +require RT::ScripActions; + +use Getopt::Long qw(GetOptions); + +our $cmd = 'usage'; +our $opts = {}; + +sub parse_args { + my $tmp; + Getopt::Long::Configure( "pass_through" ); + if ( GetOptions( 'list' => \$tmp ) && $tmp ) { + $cmd = 'list'; + } + elsif ( GetOptions( 'create=s' => \$tmp ) && $tmp ) { + $cmd = 'create'; + $opts->{'name'} = $tmp; + $opts->{'groups'} = []; + $opts->{'users'} = []; + GetOptions( 'comment' => \$opts->{'comment'} ); + GetOptions( 'group:s@' => $opts->{'groups'} ); + GetOptions( 'user:s@' => $opts->{'users'} ); + unless ( @{ $opts->{'users'} } + @{ $opts->{'groups'} } ) { + usage(); + exit(-1); + } + } + elsif ( GetOptions( 'add=s' => \$tmp ) && $tmp ) { + $cmd = 'add'; + $opts->{'name'} = $tmp; + $opts->{'groups'} = []; + $opts->{'users'} = []; + GetOptions( 'group:s@' => $opts->{'groups'} ); + GetOptions( 'user:s@' => $opts->{'users'} ); + unless ( @{ $opts->{'users'} } + @{ $opts->{'groups'} } ) { + usage(); + exit(-1); + } + } + elsif ( GetOptions( 'switch=s' => \$tmp ) && $tmp ) { + $cmd = 'switch'; + $opts->{'name'} = $tmp; + } + elsif ( GetOptions( 'rename=s' => \$tmp ) && $tmp ) { + $cmd = 'rename'; + $opts->{'name'} = $tmp; + GetOptions( 'newname=s' => \$opts->{'newname'} ); + unless ( $opts->{'newname'} ) { + usage(); + exit(-1); + } + } + elsif ( GetOptions( 'delete=s' => \$tmp ) && $tmp) { + $cmd = 'delete'; + $opts->{'name'} = $tmp; + } else { + $cmd = 'usage'; + } + + return; +} + +sub usage { + local $@; + eval "require Pod::PlainText;"; + if ( $@ ) { + print "see `perldoc $0`\n"; + } else { + my $parser = Pod::PlainText->new( sentence => 0, width => 78 ); + $parser->parse_from_file( $0 ); + } +} + +parse_args(); + +{ + eval "main::$cmd()"; + if ( $@ ) { + print STDERR $@ ."\n"; + } +} + +exit(0); + +=head1 USAGE + +rt-email-group-admin --COMMAND ARGS + +=head1 COMMANDS + +=head2 list + +Lists actions and its descriptions. + +=cut + +sub list { + my $actions = _get_our_actions(); + while( my $a = $actions->Next ) { + _list( $a ); + } + return; +} + +sub _list { + my $action = shift; + + print "Name: ". $action->Name() ."\n"; + print "Module: ". $action->ExecModule() ."\n"; + + my @princ = argument_to_list( $action ); + + print "Members: \n"; + foreach( @princ ) { + my $obj = RT::Principal->new( $RT::SystemUser ); + $obj->Load( $_ ); + next unless $obj->id; + + print "\t". $obj->PrincipalType; + print "\t=> ". $obj->Object->Name; + print "(Disabled!!!)" if $obj->Disabled; + print "\n"; + } + print "\n"; + return; +} + +=head2 create NAME [--comment] [--group GNAME] [--user UNAME] + +Creates new action with NAME and adds users and/or groups to its +recipient list. Would be notify as comment if --comment specified. + +=cut + +sub create { + my $actions = RT::ScripActions->new( $RT::SystemUser ); + $actions->Limit( + FIELD => 'Name', + VALUE => $opts->{'name'}, + ); + if ( $actions->Count ) { + print STDERR "ScripAction '". $opts->{'name'} ."' allready exists\n"; + exit(-1); + } + + my @groups = _check_groups( @{ $opts->{'groups'} } ); + my @users = _check_users( @{ $opts->{'users'} } ); + unless ( @users + @groups ) { + print STDERR "List of groups and users is empty\n"; + exit(-1); + } + + my $action = __create_empty( $opts->{'name'}, $opts->{'comment'} ); + + __add( $action, $_ ) foreach( @users ); + __add( $action, $_ ) foreach( @groups ); + + return; +} + +sub __create_empty { + my $name = shift; + my $as_comment = shift || 0; + require RT::ScripAction; + my $action = RT::ScripAction->new( $RT::SystemUser ); + $action->Create( + Name => $name, + Description => "Created with rt-email-group-admin script", + ExecModule => $as_comment? 'NotifyGroupAsComment': 'NotifyGroup', + Argument => '', + ); + + return $action; +} + +sub _check_groups +{ + return grep { $_ ? 1: do { print STDERR "Group '$_' skipped, doesn't exist\n"; 0; } } + map { __check_group($_) } @_; +} + +sub __check_group +{ + my $instance = shift; + require RT::Group; + my $obj = RT::Group->new( $RT::SystemUser ); + $obj->LoadUserDefinedGroup( $instance ); + return $obj->id ? $obj : undef; +} + +sub _check_users +{ + return grep { $_ ? 1: do { print STDERR "User '$_' skipped, doesn't exist\n"; 0; } } + map { __check_user($_) } @_; +} + +sub __check_user +{ + my $instance = shift; + require RT::User; + my $obj = RT::User->new( $RT::SystemUser ); + $obj->Load( $instance ); + return $obj->id ? $obj : undef; +} + +=head2 add NAME [--group GNAME] [--user UNAME] + +Adds groups and/or users to recipients of the action NAME. + +=cut + +sub add { + my $action = _get_action_by_name( $opts->{'name'} ); + unless ( $action ) { + print STDERR "ScripAction '". $opts->{'name'} ."' doesn't exist\n"; + exit(-1); + } + + my @groups = _check_groups( @{ $opts->{'groups'} } ); + my @users = _check_users( @{ $opts->{'users'} } ); + + unless ( @users + @groups ) { + print STDERR "List of groups and users is empty\n"; + exit(-1); + } + + __add( $action, $_ ) foreach @users; + __add( $action, $_ ) foreach @groups; + + return; +} + +sub __add +{ + my $action = shift; + my $obj = shift; + + my @cur = argument_to_list( $action ); + + my $id = $obj->id; + return if grep $_ == $id, @cur; + + push @cur, $id; + + return $action->__Set( Field => 'Argument', Value => join(',', @cur) ); +} + +=head2 delete NAME + +Deletes action NAME if scrips doesn't use it. + +=cut + +sub delete { + my $action = _get_action_by_name( $opts->{'name'} ); + unless ( $action ) { + print STDERR "ScripAction '". $opts->{'name'} ."' doesn't exist\n"; + exit(-1); + } + + require RT::Scrips; + my $scrips = RT::Scrips->new( $RT::SystemUser ); + $scrips->Limit( FIELD => 'ScripAction', VALUE => $action->id ); + if ( $scrips->Count ) { + my @sid; + while( my $s = $scrips->Next ) { + push @sid, $s->id; + } + print STDERR "ScripAction '". $opts->{'name'} ."'" + . " is in use by Scrip(s) ". join( ", ", map "#$_", @sid ) + . "\n"; + exit(-1); + } + + return __delete( $action ); +} + +sub __delete { + require DBIx::SearchBuilder::Record; + return DBIx::SearchBuilder::Record::Delete( shift ); +} + +sub _get_action_by_name { + my $name = shift; + my $actions = _get_our_actions(); + $actions->Limit( + FIELD => 'Name', + VALUE => $name + ); + + if ( $actions->Count > 1 ) { + print STDERR "More then one ScripAction with name '$name'\n"; + } + + return $actions->First; +} + +=head2 switch NAME + +Switch action NAME from notify as correspondence to comment and back. + +=cut + +sub switch { + my $action = _get_action_by_name( $opts->{'name'} ); + unless ( $action ) { + print STDERR "ScripAction '". $opts->{'name'} ."' doesn't exist\n"; + exit(-1); + } + + my %h = ( + NotifyGroup => 'NotifyGroupAsComment', + NotifyGroupAsComment => 'NotifyGroup' + ); + + return $action->__Set( + Field => 'ExecModule', + Value => $h{ $action->ExecModule } + ); +} + +=head2 rename NAME --newname NEWNAME + +Renames action NAME to NEWNAME. + +=cut + +sub rename { + my $action = _get_action_by_name( $opts->{'name'} ); + unless ( $action ) { + print STDERR "ScripAction '". $opts->{'name'} ."' doesn't exist\n"; + exit(-1); + } + + my $actions = RT::ScripActions->new( $RT::SystemUser ); + $actions->Limit( FIELD => 'Name', VALUE => $opts->{'newname'} ); + if ( $actions->Count ) { + print STDERR "ScripAction '". $opts->{'newname'} ."' allready exists\n"; + exit(-1); + } + + return $action->__Set( + Field => 'Name', + Value => $opts->{'newname'}, + ); +} + +=head2 NOTES + +If command has option --group or --user then you can use it more then once, +if other is not specified. + +=cut + +############### +#### Utils #### +############### + +sub argument_to_list { + my $action = shift; + require RT::Action::NotifyGroup; + return RT::Action::NotifyGroup->__SplitArg( $action->Argument ); +} + +sub _get_our_actions { + my $actions = RT::ScripActions->new( $RT::SystemUser ); + $actions->Limit( + FIELD => 'ExecModule', + VALUE => 'NotifyGroup', + ENTRYAGGREGATOR => 'OR', + ); + $actions->Limit( + FIELD => 'ExecModule', + VALUE => 'NotifyGroupAsComment', + ENTRYAGGREGATOR => 'OR', + ); + + return $actions; +} + +=head1 AUTHOR + +Ruslan U. Zakirov E<lt>ruz@bestpractical.comE<gt> + +=head1 SEE ALSO + +L<RT::Action::NotifyGroup>, L<RT::Action::NotifyGroupAsComment> + +=cut diff --git a/rt/sbin/rt-email-group-admin.in b/rt/sbin/rt-email-group-admin.in new file mode 100755 index 0000000..dd6548f --- /dev/null +++ b/rt/sbin/rt-email-group-admin.in @@ -0,0 +1,508 @@ +#!@PERL@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +=head1 NAME + +rt-email-group-admin - Command line tool for administrating NotifyGroup actions + +=head1 SYNOPSIS + + rt-email-group-admin --list + rt-email-group-admin --create 'Notify foo team' --group Foo + rt-email-group-admin --create 'Notify foo team as comment' --comment --group Foo + rt-email-group-admin --create 'Notify group Foo and Bar' --group Foo --group Bar + rt-email-group-admin --create 'Notify user foo@bar.com' --user foo@bar.com + rt-email-group-admin --create 'Notify VIPs' --user vip1@bar.com + rt-email-group-admin --add 'Notify VIPs' --user vip2@bar.com --group vip1 --user vip3@foo.com + rt-email-group-admin --rename 'Notify VIPs' --newname 'Inform VIPs' + rt-email-group-admin --switch 'Notify VIPs' + rt-email-group-admin --delete 'Notify user foo@bar.com' + +=head1 DESCRIPTION + +This script list, create, modify or delete scrip actions in the RT DB. Once +you've created an action you can use it in a scrip. + +For example you can create the following action using this script: + + rt-email-group-admin --create 'Notify developers' --group 'Development Team' + +Then you can add the followoing scrip to your Bugs queue: + + Condition: On Create + Action: Notify developers + Template: Transaction + Stage: TransactionCreate + +Your development team will be notified on every new ticket in the queue. + +=cut + +use warnings; +use strict; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use RT; +RT::LoadConfig; +RT::Init; + +require RT::Principal; +require RT::User; +require RT::Group; +require RT::ScripActions; + +use Getopt::Long qw(GetOptions); + +our $cmd = 'usage'; +our $opts = {}; + +sub parse_args { + my $tmp; + Getopt::Long::Configure( "pass_through" ); + if ( GetOptions( 'list' => \$tmp ) && $tmp ) { + $cmd = 'list'; + } + elsif ( GetOptions( 'create=s' => \$tmp ) && $tmp ) { + $cmd = 'create'; + $opts->{'name'} = $tmp; + $opts->{'groups'} = []; + $opts->{'users'} = []; + GetOptions( 'comment' => \$opts->{'comment'} ); + GetOptions( 'group:s@' => $opts->{'groups'} ); + GetOptions( 'user:s@' => $opts->{'users'} ); + unless ( @{ $opts->{'users'} } + @{ $opts->{'groups'} } ) { + usage(); + exit(-1); + } + } + elsif ( GetOptions( 'add=s' => \$tmp ) && $tmp ) { + $cmd = 'add'; + $opts->{'name'} = $tmp; + $opts->{'groups'} = []; + $opts->{'users'} = []; + GetOptions( 'group:s@' => $opts->{'groups'} ); + GetOptions( 'user:s@' => $opts->{'users'} ); + unless ( @{ $opts->{'users'} } + @{ $opts->{'groups'} } ) { + usage(); + exit(-1); + } + } + elsif ( GetOptions( 'switch=s' => \$tmp ) && $tmp ) { + $cmd = 'switch'; + $opts->{'name'} = $tmp; + } + elsif ( GetOptions( 'rename=s' => \$tmp ) && $tmp ) { + $cmd = 'rename'; + $opts->{'name'} = $tmp; + GetOptions( 'newname=s' => \$opts->{'newname'} ); + unless ( $opts->{'newname'} ) { + usage(); + exit(-1); + } + } + elsif ( GetOptions( 'delete=s' => \$tmp ) && $tmp) { + $cmd = 'delete'; + $opts->{'name'} = $tmp; + } else { + $cmd = 'usage'; + } + + return; +} + +sub usage { + local $@; + eval "require Pod::PlainText;"; + if ( $@ ) { + print "see `perldoc $0`\n"; + } else { + my $parser = Pod::PlainText->new( sentence => 0, width => 78 ); + $parser->parse_from_file( $0 ); + } +} + +parse_args(); + +{ + eval "main::$cmd()"; + if ( $@ ) { + print STDERR $@ ."\n"; + } +} + +exit(0); + +=head1 USAGE + +rt-email-group-admin --COMMAND ARGS + +=head1 COMMANDS + +=head2 list + +Lists actions and its descriptions. + +=cut + +sub list { + my $actions = _get_our_actions(); + while( my $a = $actions->Next ) { + _list( $a ); + } + return; +} + +sub _list { + my $action = shift; + + print "Name: ". $action->Name() ."\n"; + print "Module: ". $action->ExecModule() ."\n"; + + my @princ = argument_to_list( $action ); + + print "Members: \n"; + foreach( @princ ) { + my $obj = RT::Principal->new( $RT::SystemUser ); + $obj->Load( $_ ); + next unless $obj->id; + + print "\t". $obj->PrincipalType; + print "\t=> ". $obj->Object->Name; + print "(Disabled!!!)" if $obj->Disabled; + print "\n"; + } + print "\n"; + return; +} + +=head2 create NAME [--comment] [--group GNAME] [--user UNAME] + +Creates new action with NAME and adds users and/or groups to its +recipient list. Would be notify as comment if --comment specified. + +=cut + +sub create { + my $actions = RT::ScripActions->new( $RT::SystemUser ); + $actions->Limit( + FIELD => 'Name', + VALUE => $opts->{'name'}, + ); + if ( $actions->Count ) { + print STDERR "ScripAction '". $opts->{'name'} ."' allready exists\n"; + exit(-1); + } + + my @groups = _check_groups( @{ $opts->{'groups'} } ); + my @users = _check_users( @{ $opts->{'users'} } ); + unless ( @users + @groups ) { + print STDERR "List of groups and users is empty\n"; + exit(-1); + } + + my $action = __create_empty( $opts->{'name'}, $opts->{'comment'} ); + + __add( $action, $_ ) foreach( @users ); + __add( $action, $_ ) foreach( @groups ); + + return; +} + +sub __create_empty { + my $name = shift; + my $as_comment = shift || 0; + require RT::ScripAction; + my $action = RT::ScripAction->new( $RT::SystemUser ); + $action->Create( + Name => $name, + Description => "Created with rt-email-group-admin script", + ExecModule => $as_comment? 'NotifyGroupAsComment': 'NotifyGroup', + Argument => '', + ); + + return $action; +} + +sub _check_groups +{ + return grep { $_ ? 1: do { print STDERR "Group '$_' skipped, doesn't exist\n"; 0; } } + map { __check_group($_) } @_; +} + +sub __check_group +{ + my $instance = shift; + require RT::Group; + my $obj = RT::Group->new( $RT::SystemUser ); + $obj->LoadUserDefinedGroup( $instance ); + return $obj->id ? $obj : undef; +} + +sub _check_users +{ + return grep { $_ ? 1: do { print STDERR "User '$_' skipped, doesn't exist\n"; 0; } } + map { __check_user($_) } @_; +} + +sub __check_user +{ + my $instance = shift; + require RT::User; + my $obj = RT::User->new( $RT::SystemUser ); + $obj->Load( $instance ); + return $obj->id ? $obj : undef; +} + +=head2 add NAME [--group GNAME] [--user UNAME] + +Adds groups and/or users to recipients of the action NAME. + +=cut + +sub add { + my $action = _get_action_by_name( $opts->{'name'} ); + unless ( $action ) { + print STDERR "ScripAction '". $opts->{'name'} ."' doesn't exist\n"; + exit(-1); + } + + my @groups = _check_groups( @{ $opts->{'groups'} } ); + my @users = _check_users( @{ $opts->{'users'} } ); + + unless ( @users + @groups ) { + print STDERR "List of groups and users is empty\n"; + exit(-1); + } + + __add( $action, $_ ) foreach @users; + __add( $action, $_ ) foreach @groups; + + return; +} + +sub __add +{ + my $action = shift; + my $obj = shift; + + my @cur = argument_to_list( $action ); + + my $id = $obj->id; + return if grep $_ == $id, @cur; + + push @cur, $id; + + return $action->__Set( Field => 'Argument', Value => join(',', @cur) ); +} + +=head2 delete NAME + +Deletes action NAME if scrips doesn't use it. + +=cut + +sub delete { + my $action = _get_action_by_name( $opts->{'name'} ); + unless ( $action ) { + print STDERR "ScripAction '". $opts->{'name'} ."' doesn't exist\n"; + exit(-1); + } + + require RT::Scrips; + my $scrips = RT::Scrips->new( $RT::SystemUser ); + $scrips->Limit( FIELD => 'ScripAction', VALUE => $action->id ); + if ( $scrips->Count ) { + my @sid; + while( my $s = $scrips->Next ) { + push @sid, $s->id; + } + print STDERR "ScripAction '". $opts->{'name'} ."'" + . " is in use by Scrip(s) ". join( ", ", map "#$_", @sid ) + . "\n"; + exit(-1); + } + + return __delete( $action ); +} + +sub __delete { + require DBIx::SearchBuilder::Record; + return DBIx::SearchBuilder::Record::Delete( shift ); +} + +sub _get_action_by_name { + my $name = shift; + my $actions = _get_our_actions(); + $actions->Limit( + FIELD => 'Name', + VALUE => $name + ); + + if ( $actions->Count > 1 ) { + print STDERR "More then one ScripAction with name '$name'\n"; + } + + return $actions->First; +} + +=head2 switch NAME + +Switch action NAME from notify as correspondence to comment and back. + +=cut + +sub switch { + my $action = _get_action_by_name( $opts->{'name'} ); + unless ( $action ) { + print STDERR "ScripAction '". $opts->{'name'} ."' doesn't exist\n"; + exit(-1); + } + + my %h = ( + NotifyGroup => 'NotifyGroupAsComment', + NotifyGroupAsComment => 'NotifyGroup' + ); + + return $action->__Set( + Field => 'ExecModule', + Value => $h{ $action->ExecModule } + ); +} + +=head2 rename NAME --newname NEWNAME + +Renames action NAME to NEWNAME. + +=cut + +sub rename { + my $action = _get_action_by_name( $opts->{'name'} ); + unless ( $action ) { + print STDERR "ScripAction '". $opts->{'name'} ."' doesn't exist\n"; + exit(-1); + } + + my $actions = RT::ScripActions->new( $RT::SystemUser ); + $actions->Limit( FIELD => 'Name', VALUE => $opts->{'newname'} ); + if ( $actions->Count ) { + print STDERR "ScripAction '". $opts->{'newname'} ."' allready exists\n"; + exit(-1); + } + + return $action->__Set( + Field => 'Name', + Value => $opts->{'newname'}, + ); +} + +=head2 NOTES + +If command has option --group or --user then you can use it more then once, +if other is not specified. + +=cut + +############### +#### Utils #### +############### + +sub argument_to_list { + my $action = shift; + require RT::Action::NotifyGroup; + return RT::Action::NotifyGroup->__SplitArg( $action->Argument ); +} + +sub _get_our_actions { + my $actions = RT::ScripActions->new( $RT::SystemUser ); + $actions->Limit( + FIELD => 'ExecModule', + VALUE => 'NotifyGroup', + ENTRYAGGREGATOR => 'OR', + ); + $actions->Limit( + FIELD => 'ExecModule', + VALUE => 'NotifyGroupAsComment', + ENTRYAGGREGATOR => 'OR', + ); + + return $actions; +} + +=head1 AUTHOR + +Ruslan U. Zakirov E<lt>ruz@bestpractical.comE<gt> + +=head1 SEE ALSO + +L<RT::Action::NotifyGroup>, L<RT::Action::NotifyGroupAsComment> + +=cut diff --git a/rt/sbin/rt-server b/rt/sbin/rt-server new file mode 100755 index 0000000..2c7eca5 --- /dev/null +++ b/rt/sbin/rt-server @@ -0,0 +1,129 @@ +#!/usr/bin/perl -w +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use warnings; +use strict; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use RT; +RT::LoadConfig(); +RT->InitLogging(); +if (RT->Config->Get('DevelMode')) { require Module::Refresh; } + +RT::CheckPerlRequirements(); +RT->InitPluginPaths(); + +my $port = shift @ARGV || RT->Config->Get('WebPort') || '8080'; + + +require RT::Handle; +my ($integrity, $state, $msg) = RT::Handle->CheckIntegrity; + +unless ( $integrity ) { + print STDERR <<EOF; + +RT couldn't connect to the database where tickets are stored. +If this is a new installation of RT, you should visit the URL below +to configure RT and initialize your database. + +If this is an existing RT installation, this may indicate a database +connectivity problem. + +The error RT got back when trying to connect to your database was: + +$msg + +EOF + + require RT::Installer; + # don't enter install mode if the file exists but is unwritable + if (-e RT::Installer->ConfigFile && !-w _) { + die "Since your configuration exists but is not writable, I'm refusing to do anything.\n"; + } + + RT->Config->Set( 'LexiconLanguages' => '*' ); + RT::I18N->Init; + + RT->InstallMode(1); +} else { + RT->ConnectToDatabase(); + RT->InitSystemObjects(); + RT->InitClasses(); + RT->InitPlugins(); +} + +require RT::Interface::Web::Standalone; +my $server = RT::Interface::Web::Standalone->new; +$server->net_server('RT::Interface::Web::Standalone::PreFork'); +$server->port($port); +$server->run(); + diff --git a/rt/sbin/rt-server.in b/rt/sbin/rt-server.in new file mode 100644 index 0000000..cd146e0 --- /dev/null +++ b/rt/sbin/rt-server.in @@ -0,0 +1,129 @@ +#!@PERL@ -w +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use warnings; +use strict; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use RT; +RT::LoadConfig(); +RT->InitLogging(); +if (RT->Config->Get('DevelMode')) { require Module::Refresh; } + +RT::CheckPerlRequirements(); +RT->InitPluginPaths(); + +my $port = shift @ARGV || RT->Config->Get('WebPort') || '8080'; + + +require RT::Handle; +my ($integrity, $state, $msg) = RT::Handle->CheckIntegrity; + +unless ( $integrity ) { + print STDERR <<EOF; + +RT couldn't connect to the database where tickets are stored. +If this is a new installation of RT, you should visit the URL below +to configure RT and initialize your database. + +If this is an existing RT installation, this may indicate a database +connectivity problem. + +The error RT got back when trying to connect to your database was: + +$msg + +EOF + + require RT::Installer; + # don't enter install mode if the file exists but is unwritable + if (-e RT::Installer->ConfigFile && !-w _) { + die "Since your configuration exists but is not writable, I'm refusing to do anything.\n"; + } + + RT->Config->Set( 'LexiconLanguages' => '*' ); + RT::I18N->Init; + + RT->InstallMode(1); +} else { + RT->ConnectToDatabase(); + RT->InitSystemObjects(); + RT->InitClasses(); + RT->InitPlugins(); +} + +require RT::Interface::Web::Standalone; +my $server = RT::Interface::Web::Standalone->new; +$server->net_server('RT::Interface::Web::Standalone::PreFork'); +$server->port($port); +$server->run(); + diff --git a/rt/sbin/rt-setup-database b/rt/sbin/rt-setup-database index 49af151..d4a256f 100644 --- a/rt/sbin/rt-setup-database +++ b/rt/sbin/rt-setup-database @@ -1,9 +1,9 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -47,41 +47,56 @@ # # END BPS TAGGED BLOCK }}} use strict; -use vars qw($PROMPT $VERSION $Handle $Nobody $SystemUser $item); -use vars - qw(@Groups @Users @ACL @Queues @ScripActions @ScripConditions @Templates @CustomFields @Scrips @Attributes); +use warnings; + +use vars qw($Nobody $SystemUser $item); -use lib "/opt/rt3/local/lib"; -use lib "/opt/rt3/lib"; +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} #This drags in RT's config.pm # We do it in a begin block because RT::Handle needs to know the type to do its # inheritance -use RT; -use Carp; -use RT::User; -use RT::CurrentUser; -use RT::Template; -use RT::ScripAction; -use RT::ACE; -use RT::Group; -use RT::User; -use RT::Queue; -use RT::ScripCondition; -use RT::CustomField; -use RT::Scrip; - -RT::LoadConfig(); +BEGIN { + use RT; + RT::LoadConfig(); + RT::InitClasses(); +} + use Term::ReadKey; use Getopt::Long; -my %args; +$| = 1; # unbuffer all output. +my %args; GetOptions( \%args, - 'prompt-for-dba-password', 'force', 'debug', - 'action=s', 'dba=s', 'dba-password=s', 'datafile=s', - 'datadir=s' + 'action=s', + 'force', 'debug', + 'dba=s', 'dba-password=s', 'prompt-for-dba-password', + 'datafile=s', 'datadir=s' ); unless ( $args{'action'} ) { @@ -89,583 +104,321 @@ unless ( $args{'action'} ) { exit(-1); } -$| = 1; #unbuffer that output. - -require RT::Handle; -my $Handle = RT::Handle->new($RT::DatabaseType); -$Handle->BuildDSN; -my $dbh; - -if ( $args{'prompt-for-dba-password'} ) { - $args{'dba-password'} = get_dba_password(); - chomp( $args{'dba-password'} ); -} - -if ( $args{'action'} eq 'init' ) { - $dbh = DBI->connect( get_system_dsn(), $args{'dba'}, $args{'dba-password'} ) - || die "Failed to connect to " . get_system_dsn() . " as $args{'dba'}: $DBI::errstr"; - print "Now creating a database for RT.\n"; - if ( $RT::DatabaseType ne 'Oracle' || $args{'dba'} ne $RT::DatabaseUser ) { - create_db(); - } else { - print "...skipped as ".$args{'dba'} ." is not " . $RT::DatabaseUser . " or we're working with Oracle.\n"; - } - - if ( $RT::DatabaseType eq "mysql" ) { - # Check which version we're running - my ($version) = $dbh->selectrow_hashref("show variables like 'version'")->{Value} =~ /^(\d\.\d+)/; - print "*** Warning: RT is unsupported on MySQL versions before 4.0.x\n" if $version < 4; - - # MySQL must have InnoDB support - my $innodb = $dbh->selectrow_hashref("show variables like 'have_innodb'")->{Value}; - if ( $innodb eq "NO" ) { - die "RT requires that MySQL be compiled with InnoDB table support.\n". - "See http://dev.mysql.com/doc/mysql/en/InnoDB.html\n"; - } elsif ( $innodb eq "DISABLED" ) { - die "RT requires that MySQL InnoDB table support be enabled.\n". - ($version < 4 - ? "Add 'innodb_data_file_path=ibdata1:10M:autoextend' to the [mysqld] section of my.cnf\n" - : "Remove the 'skip-innodb' line from your my.cnf file, restart MySQL, and try again.\n"); - } - } - - # SQLite can't deal with the disconnect/reconnect - unless ( $RT::DatabaseType eq 'SQLite' ) { - - $dbh->disconnect; - - if ( $RT::DatabaseType eq "Oracle" ) { - $RT::DatabasePassword = $RT::DatabasePassword; #Warning avidance - $dbh = DBI->connect( $Handle->DSN, ${RT::DatabaseUser}, ${RT::DatabasePassword} ) || die $DBI::errstr; - } else { - $dbh = DBI->connect( $Handle->DSN, $args{'dba'}, $args{'dba-password'} ) || die $DBI::errstr; - } - } - print "Now populating database schema.\n"; - insert_schema(); - print "Now inserting database ACLs\n"; - insert_acl() unless $RT::DatabaseType eq 'Oracle'; - print "Now inserting RT core system objects\n"; - insert_initial_data(); - print "Now inserting RT data\n"; - insert_data( $RT::EtcPath . "/initialdata" ); -} -elsif ( $args{'action'} eq 'drop' ) { - unless ( $dbh = - DBI->connect( get_system_dsn(), $args{'dba'}, $args{'dba-password'} ) ) - { - warn $DBI::errstr; - warn "Database doesn't appear to exist. Aborting database drop."; - exit; - } - drop_db(); -} -elsif ( $args{'action'} eq 'insert' ) { - insert_data( $args{'datafile'} || ($args{'datadir'}."/content") ); -} -elsif ( $args{'action'} eq 'acl' ) { - $dbh = DBI->connect( $Handle->DSN, $args{'dba'}, $args{'dba-password'} ) - || die "Failed to connect to " . get_system_dsn() . " as $args{'dba'}: $DBI::errstr"; - insert_acl($args{'datadir'}); -} -elsif ( $args{'action'} eq 'schema' ) { - $dbh = DBI->connect( $Handle->DSN, $args{'dba'}, $args{'dba-password'} ) - || die "Failed to connect to " . get_system_dsn() . " as $args{'dba'}: $DBI::errstr"; - insert_schema($args{'datadir'}); -} -else { - print STDERR "$0 called with an invalid --action parameter\n"; +# check and setup @actions +my @actions = grep $_, split /,/, $args{'action'}; +if ( @actions > 1 && $args{'datafile'} ) { + print STDERR "You can not use --datafile option with multiple actions.\n"; exit(-1); } - -# {{{ sub insert_schema -sub insert_schema { - my $base_path = (shift || $RT::EtcPath); - my (@schema); - print "Creating database schema.\n"; - - my $schema_file = $base_path . "/schema." . $RT::DatabaseType; - if ( -f $schema_file ) { - open( SCHEMA, "<$schema_file" ) or die "Can't open $schema_file: $!"; - my @lines = <SCHEMA>; - - my $local_schema_file = $RT::LocalEtcPath . "/schema." . $RT::DatabaseType; - if (-f $local_schema_file) { - open( SCHEMA_LOCAL, "<$local_schema_file" ) - or die "Can't open $local_schema_file: $!"; - push @lines, ';;', <SCHEMA_LOCAL>; - } - - my $statement = ""; - foreach my $line (@lines) { - $line =~ s/\#.*//g; - $line =~ s/--.*//g; - $statement .= $line; - if ( $line =~ /;(\s*)$/ ) { - $statement =~ s/;(\s*)$//g; - push @schema, $statement; - $statement = ""; - } - } - - local $SIG{__WARN__} = sub {}; - my $is_local = 0; # local/etc/schema needs to be nonfatal. - $dbh->begin_work or die $dbh->errstr; - foreach my $statement (@schema) { - if ( $statement =~ /^\s*;$/ ) { $is_local = 1; next; } - - print STDERR "SQL: $statement\n" if defined $args{'debug'}; - my $sth = $dbh->prepare($statement) or die $dbh->errstr; - unless ( $sth->execute or $is_local ) { - die "Problem with statement:\n $statement\n" . $sth->errstr; - } - } - $dbh->commit or die $dbh->errstr; +foreach ( @actions ) { + unless ( /^(?:init|create|drop|schema|acl|coredata|insert|upgrade)$/ ) { + print STDERR "$0 called with an invalid --action parameter.\n"; + exit(-1); } - else { - die "Couldn't find schema file for " . $RT::DatabaseType . "\n"; + if ( /^(?:init|drop|upgrade)$/ && @actions > 1 ) { + print STDERR "You can not mix init, drop or upgrade action with any action.\n"; + exit(-1); } - print "Done setting up database schema.\n"; } -# }}} - -# {{{ sub drop_db -sub drop_db { - if ( $RT::DatabaseType eq 'Oracle' ) { - print <<END; - -To delete the tables and sequences of the RT Oracle database by running - \@etc/drop.Oracle -through SQLPlus. +# convert init to multiple actions +my $init = 0; +if ( $actions[0] eq 'init' ) { + @actions = qw(create schema acl coredata insert); + $init = 1; +} -END - return; - } - unless ( $args{'force'} ) { - print <<END; +# set options from environment +foreach my $key(qw(Type Host Name User Password)) { + next unless exists $ENV{ 'RT_DB_'. uc $key }; + print "Using Database$key from RT_DB_". uc($key) ." environment variable.\n"; + RT->Config->Set( "Database$key", $ENV{ 'RT_DB_'. uc $key }); +} -About to drop $RT::DatabaseType database $RT::DatabaseName on $RT::DatabaseHost. -WARNING: This will erase all data in $RT::DatabaseName. +my $db_type = RT->Config->Get('DatabaseType') || ''; +my $db_host = RT->Config->Get('DatabaseHost') || ''; +my $db_name = RT->Config->Get('DatabaseName') || ''; +my $db_user = RT->Config->Get('DatabaseUser') || ''; +my $db_pass = RT->Config->Get('DatabasePassword') || ''; -END - exit unless _yesno(); +# load it here to get error immidiatly if DB type is not supported +require RT::Handle; - } +if ( $db_type eq 'SQLite' && !File::Spec->file_name_is_absolute($db_name) ) { + $db_name = File::Spec->catfile($RT::VarPath, $db_name); + RT->Config->Set( DatabaseName => $db_name ); +} - print "Dropping $RT::DatabaseType database $RT::DatabaseName.\n"; +my $dba_user = $args{'dba'} || $ENV{'RT_DBA_USER'} || $db_user || ''; +my $dba_pass = $args{'dba-password'} || $ENV{'RT_DBA_PASSWORD'}; - if ( $RT::DatabaseType eq 'SQLite' ) { - unlink $RT::DatabaseName or warn $!; - return; - } - $dbh->do("Drop DATABASE $RT::DatabaseName") or warn $DBI::errstr; +if ( !$args{force} && ( !defined $dba_pass || $args{'prompt-for-dba-password'} ) ) { + $dba_pass = get_dba_password(); + chomp $dba_pass if defined($dba_pass); } -# }}} +print "Working with:\n" + ."Type:\t$db_type\nHost:\t$db_host\nName:\t$db_name\n" + ."User:\t$db_user\nDBA:\t$dba_user\n"; -# {{{ sub create_db -sub create_db { - print "Creating $RT::DatabaseType database $RT::DatabaseName.\n"; - if ( $RT::DatabaseType eq 'SQLite' ) { - return; - } - elsif ( $RT::DatabaseType eq 'Pg' ) { - $dbh->do("CREATE DATABASE $RT::DatabaseName WITH ENCODING='UNICODE'"); - if ( $DBI::errstr ) { - $dbh->do("CREATE DATABASE $RT::DatabaseName") || die $DBI::errstr; - } - } - elsif ( $RT::DatabaseType eq 'Oracle' ) { - insert_acl(); - } - elsif ( $RT::DatabaseType eq 'Informix' ) { - $ENV{DB_LOCALE} = 'en_us.utf8'; - $dbh->do("CREATE DATABASE $RT::DatabaseName WITH BUFFERED LOG"); - } - else { - $dbh->do("CREATE DATABASE $RT::DatabaseName") or die $DBI::errstr; - } +foreach my $action ( @actions ) { + no strict 'refs'; + my ($status, $msg) = *{ 'action_'. $action }{'CODE'}->( %args ); + error($action, $msg) unless $status; + print $msg ."\n" if $msg; + print "Done.\n"; } -# }}} +sub action_create { + my %args = @_; + my $dbh = get_system_dbh(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $dbh, 'pre' ); + return ($status, $msg) unless $status; -sub get_dba_password { - print "In order to create or update your RT database,"; - print "this script needs to connect to your " - . $RT::DatabaseType - . " instance on " - . $RT::DatabaseHost . " as " - . $args{'dba'} . ".\n"; - print "Please specify that user's database password below. If the user has no database\n"; - print "password, just press return.\n\n"; - print "Password: "; - ReadMode('noecho'); - my $password = ReadLine(0); - ReadMode('normal'); - print "\n"; - return ($password); + print "Now creating a $db_type database $db_name for RT.\n"; + return RT::Handle->CreateDatabase( $dbh ); } -# {{{ sub _yesno -sub _yesno { - print "Proceed [y/N]:"; - my $x = scalar(<STDIN>); - $x =~ /^y/i; -} +sub action_drop { + my %args = @_; -# }}} + print "Dropping $db_type database $db_name.\n"; + unless ( $args{'force'} ) { + print <<END; -# {{{ insert_acls -sub insert_acl { - my $base_path = (shift || $RT::EtcPath); +About to drop $db_type database $db_name on $db_host. +WARNING: This will erase all data in $db_name. - if ( $RT::DatabaseType =~ /^oracle$/i ) { - do $base_path . "/acl.Oracle" - || die "Couldn't find ACLS for Oracle\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^pg$/i ) { - do $base_path . "/acl.Pg" || die "Couldn't find ACLS for Pg\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^mysql$/i ) { - do $base_path . "/acl.mysql" - || die "Couldn't find ACLS for mysql in $base_path\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^Sybase$/i ) { - do $base_path . "/acl.Sybase" - || die "Couldn't find ACLS for Sybase in $base_path\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^informix$/i ) { - do $base_path . "/acl.Informix" - || die "Couldn't find ACLS for Informix in $base_path\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^SQLite$/i ) { - return; - } - else { - die "Unknown RT database type"; +END + exit(-2) unless _yesno(); } - my @acl = acl($dbh); - foreach my $statement (@acl) { - print STDERR $statement if $args{'debug'}; - my $sth = $dbh->prepare($statement) or die $dbh->errstr; - unless ( $sth->execute ) { - die "Problem with statement:\n $statement\n" . $sth->errstr; - } - } - print "Done setting up database ACLs.\n"; + my $dbh = get_system_dbh(); + return RT::Handle->DropDatabase( $dbh ); } -# }}} - -=head2 get_system_dsn - -Returns a dsn suitable for database creates and drops -and user creates and drops - -=cut - -sub get_system_dsn { +sub action_schema { + my %args = @_; + my $dbh = get_admin_dbh(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $dbh, 'pre' ); + return ($status, $msg) unless $status; - my $dsn = $Handle->DSN; + print "Now populating database schema.\n"; + return RT::Handle->InsertSchema( $dbh, $args{'datafile'} || $args{'datadir'} ); +} - #with mysql, you want to connect sans database to funge things - if ( $RT::DatabaseType eq 'mysql' ) { - $dsn =~ s/dbname=$RT::DatabaseName//; +sub action_acl { + my %args = @_; + my $dbh = get_admin_dbh(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $dbh, 'pre' ); + return ($status, $msg) unless $status; - # with postgres, you want to connect to database1 - } - elsif ( $RT::DatabaseType eq 'Pg' ) { - $dsn =~ s/dbname=$RT::DatabaseName/dbname=template1/; - } - elsif ( $RT::DatabaseType eq 'Informix' ) { - # with Informix, you want to connect sans database: - $dsn =~ s/Informix:$RT::DatabaseName/Informix:/; - } - return $dsn; + print "Now inserting database ACLs\n"; + return RT::Handle->InsertACL( $dbh, $args{'datafile'} || $args{'datadir'} ); } -sub insert_initial_data { - +sub action_coredata { + my %args = @_; + $RT::Handle = new RT::Handle; + $RT::Handle->dbh( undef ); + RT::ConnectToDatabase(); RT::InitLogging(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $RT::Handle->dbh, 'pre' ); + return ($status, $msg) unless $status; - #connect to the db, for actual RT work - require RT::Handle; - $RT::Handle = RT::Handle->new(); - $RT::Handle->Connect(); - - #Put together a current user object so we can create a User object - my $CurrentUser = new RT::CurrentUser(); - - print "Checking for existing system user..."; - my $test_user = RT::User->new($CurrentUser); - $test_user->Load('RT_System'); - if ( $test_user->id ) { - print "found!\n\nYou appear to have a functional RT database.\n" - . "Exiting, so as not to clobber your existing data.\n"; - exit(-1); - - } - else { - print "not found. This appears to be a new installation.\n"; - } - - print "Creating system user..."; - my $RT_System = new RT::User($CurrentUser); - - my ( $val, $msg ) = $RT_System->_BootstrapCreate( - Name => 'RT_System', - RealName => 'The RT System itself', - Comments => -'Do not delete or modify this user. It is integral to RT\'s internal database structures', - Creator => '1', - LastUpdatedBy => '1', - ); - - unless ( $val ) { - print "$msg\n"; - exit(-1); - } - print "done.\n"; - $RT::Handle->Disconnect() unless $RT::DatabaseType eq 'SQLite'; + print "Now inserting RT core system objects\n"; + return $RT::Handle->InsertInitialData; +} +sub action_insert { + my %args = @_; + $RT::Handle = new RT::Handle; + RT::Init(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $RT::Handle->dbh, 'pre' ); + return ($status, $msg) unless $status; + + print "Now inserting data\n"; + my $file = $args{'datafile'}; + $file = $RT::EtcPath . "/initialdata" if $init && !$file; + $file ||= $args{'datadir'}."/content"; + return $RT::Handle->InsertData( $file ); } -# load some sort of data into the database +sub action_upgrade { + my %args = @_; + my $base_dir = $args{'datadir'} || "./etc/upgrade"; + return (0, "Couldn't read dir '$base_dir' with upgrade data") + unless -d $base_dir || -r _; + + my $upgrading_from = undef; + do { + if ( defined $upgrading_from ) { + print "Doesn't match #.#.#: "; + } else { + print "Enter RT version you're upgrading from: "; + } + $upgrading_from = scalar <STDIN>; + chomp $upgrading_from; + $upgrading_from =~ s/\s+//g; + } while $upgrading_from !~ /^\d+\.\d+\.\d+$/; + + my $upgrading_to = $RT::VERSION; + return (0, "The current version $upgrading_to is lower than $upgrading_from") + if RT::Handle::cmp_version( $upgrading_from, $upgrading_to ) > 0; -sub insert_data { - my $datafile = shift; + return (1, "The version $upgrading_to you're upgrading to is up to date") + if RT::Handle::cmp_version( $upgrading_from, $upgrading_to ) == 0; - #Connect to the database and get RT::SystemUser and RT::Nobody loaded - RT::Init; + my @versions = get_versions_from_to($base_dir, $upgrading_from, $upgrading_to); - my $CurrentUser = RT::CurrentUser->new(); - $CurrentUser->LoadByName('RT_System'); + return (1, "No DB changes between $upgrading_from and $upgrading_to") + unless @versions; - if ( $datafile eq $RT::EtcPath . "/initialdata" ) { + print "\nGoing to apply following upgrades:\n"; + print map "* $_\n", @versions; - print "Creating Superuser ACL..."; + { + my $custom_upgrading_to = undef; + do { + if ( defined $custom_upgrading_to ) { + print "Doesn't match #.#.#: "; + } else { + print "\nEnter RT version if you want to stop upgrade at some point,\n"; + print " or leave it blank if you want apply above upgrades: "; + } + $custom_upgrading_to = scalar <STDIN>; + chomp $custom_upgrading_to; + $custom_upgrading_to =~ s/\s+//g; + last unless $custom_upgrading_to; + } while $custom_upgrading_to !~ /^\d+\.\d+\.\d+$/; + + if ( $custom_upgrading_to ) { + return ( + 0, "The version you entered ($custom_upgrading_to) is lower than\n" + ."version you're upgrading from ($upgrading_from)" + ) if RT::Handle::cmp_version( $upgrading_from, $custom_upgrading_to ) > 0; + + return (1, "The version you're upgrading to is up to date") + if RT::Handle::cmp_version( $upgrading_from, $custom_upgrading_to ) == 0; + + if ( RT::Handle::cmp_version( $RT::VERSION, $custom_upgrading_to ) < 0 ) { + print "Version you entered is greater than installed ($RT::VERSION).\n"; + _yesno() or exit(-2); + } + # ok, checked everything no let's refresh list + $upgrading_to = $custom_upgrading_to; + @versions = get_versions_from_to($base_dir, $upgrading_from, $upgrading_to); - my $superuser_ace = RT::ACE->new($CurrentUser); - $superuser_ace->_BootstrapCreate( - PrincipalId => ACLEquivGroupId( $CurrentUser->Id ), - PrincipalType => 'Group', - RightName => 'SuperUser', - ObjectType => 'RT::System', - ObjectId => '1' ); + return (1, "No DB changes between $upgrading_from and $upgrading_to") + unless @versions; - print "done.\n"; + print "\nGoing to apply following upgrades:\n"; + print map "* $_\n", @versions; + } } - # Slurp in stuff to insert from the datafile. Possible things to go in here:- - # @groups, @users, @acl, @queues, @ScripActions, @ScripConditions, @templates - - require $datafile - || die "Couldn't find initial data for import\n" . $@; + print "\nIT'S VERY IMPORTANT TO BACK UP BEFORE THIS STEP\n\n"; + _yesno() or exit(-2) unless $args{'force'}; - if ( @Groups ) { - print "Creating groups..."; - foreach $item (@Groups) { - my $new_entry = RT::Group->new($CurrentUser); - my ( $return, $msg ) = $new_entry->_Create(%$item); - print "(Error: $msg)" unless $return; - print $return. "."; + foreach my $v ( @versions ) { + print "Processing $v\n"; + my %tmp = (%args, datadir => "$base_dir/$v", datafile => undef); + if ( -e "$base_dir/$v/schema.$db_type" ) { + action_schema( %tmp ); } - print "done.\n"; - } - if ( @Users ) { - print "Creating users..."; - foreach $item (@Users) { - my $new_entry = new RT::User($CurrentUser); - my ( $return, $msg ) = $new_entry->Create(%$item); - print "(Error: $msg)" unless $return; - print $return. "."; + if ( -e "$base_dir/$v/acl.$db_type" ) { + action_acl( %tmp ); } - print "done.\n"; - } - if ( @Queues ) { - print "Creating queues..."; - for $item (@Queues) { - my $new_entry = new RT::Queue($CurrentUser); - my ( $return, $msg ) = $new_entry->Create(%$item); - print "(Error: $msg)" unless $return; - print $return. "."; + if ( -e "$base_dir/$v/content" ) { + action_insert( %tmp ); } - print "done.\n"; } - if ( @ACL ) { - print "Creating ACL..."; - for my $item (@ACL) { - - my ($princ, $object); - - # Global rights or Queue rights? - if ( $item->{'Queue'} ) { - $object = RT::Queue->new($CurrentUser); - $object->Load( $item->{'Queue'} ); - } else { - $object = $RT::System; - } - - # Group rights or user rights? - if ( $item->{'GroupDomain'} ) { - $princ = RT::Group->new($CurrentUser); - if ( $item->{'GroupDomain'} eq 'UserDefined' ) { - $princ->LoadUserDefinedGroup( $item->{'GroupId'} ); - } elsif ( $item->{'GroupDomain'} eq 'SystemInternal' ) { - $princ->LoadSystemInternalGroup( $item->{'GroupType'} ); - } elsif ( $item->{'GroupDomain'} eq 'RT::System-Role' ) { - $princ->LoadSystemRoleGroup( $item->{'GroupType'} ); - } elsif ( $item->{'GroupDomain'} eq 'RT::Queue-Role' && - $item->{'Queue'} ) - { - $princ->LoadQueueRoleGroup( Type => $item->{'GroupType'}, - Queue => $object->id); - } else { - $princ->Load( $item->{'GroupId'} ); - } - } else { - $princ = RT::User->new($CurrentUser); - $princ->Load( $item->{'UserId'} ); - } + return 1; +} - # Grant it - my ( $return, $msg ) = $princ->PrincipalObj->GrantRight( - Right => $item->{'Right'}, - Object => $object ); +sub get_versions_from_to { + my ($base_dir, $from, $to) = @_; - if ( $return ) { - print $return. "."; - } - else { - print $msg . "."; + opendir my $dh, $base_dir or die "couldn't open dir: $!"; + my @versions = grep -d "$base_dir/$_" && /\d+\.\d+\.\d+/, readdir $dh; + closedir $dh; - } + return + grep RT::Handle::cmp_version($_, $to) <= 0, + grep RT::Handle::cmp_version($_, $from) > 0, + sort RT::Handle::cmp_version @versions; +} - } - print "done.\n"; - } - if ( @CustomFields ) { - print "Creating custom fields..."; - for $item (@CustomFields) { - my $new_entry = new RT::CustomField($CurrentUser); - my $values = $item->{'Values'}; - delete $item->{'Values'}; - my ( $return, $msg ) = $new_entry->Create(%$item); - unless( $return ) { - print "(Error: $msg)\n"; - next; - } +sub error { + my ($action, $msg) = @_; + print STDERR "Couldn't finish '$action' step.\n\n"; + print STDERR "ERROR: $msg\n\n"; + exit(-1); +} - foreach my $value ( @{$values} ) { - my ( $eval, $emsg ) = $new_entry->AddValue(%$value); - print "(Error: $emsg)\n" unless $eval; - } +sub get_dba_password { + print "In order to create or update your RT database," + . " this script needs to connect to your " + . " $db_type instance on $db_host as $dba_user\n"; + print "Please specify that user's database password below. If the user has no database\n"; + print "password, just press return.\n\n"; + print "Password: "; + ReadMode('noecho'); + my $password = ReadLine(0); + ReadMode('normal'); + print "\n"; + return ($password); +} - if ( $item->{LookupType} && !exists $item->{'Queue'} ) { # enable by default - my $ocf = RT::ObjectCustomField->new($CurrentUser); - $ocf->Create( CustomField => $new_entry->Id ); - } +=head2 get_system_dbh - print "(Error: $msg)\n" unless $return; - print $return. "."; - } +Returns L<DBI> database handle connected to B<system> with DBA credentials. - print "done.\n"; - } +See also L<RT::Handle/SystemDSN>. - if ( @ScripActions ) { - print "Creating ScripActions..."; +=cut - for $item (@ScripActions) { - my $new_entry = RT::ScripAction->new($CurrentUser); - my ($return,$msg) = $new_entry->Create(%$item); - unless ($return) { - print "(Error: $msg)\n"; - next; - } - print $return. "."; - } +sub get_system_dbh { + return _get_dbh( RT::Handle->SystemDSN, $dba_user, $dba_pass ); +} - print "done.\n"; - } +sub get_admin_dbh { + return _get_dbh( RT::Handle->DSN, $dba_user, $dba_pass ); +} - if ( @ScripConditions ) { - print "Creating ScripConditions..."; +=head2 get_rt_dbh [USER, PASSWORD] - for $item (@ScripConditions) { - my $new_entry = RT::ScripCondition->new($CurrentUser); - my ($return,$msg) = $new_entry->Create(%$item); - unless ($return) { - print "(Error: $msg)\n"; - next; - } - print $return. "."; - } +Returns L<DBI> database handle connected to RT database, +you may specify credentials(USER and PASSWORD) to connect +with. By default connects with credentials from RT config. - print "done.\n"; - } +=cut - if ( @Templates ) { - print "Creating templates..."; +sub get_rt_dbh { + return _get_dbh( RT::Handle->DSN, $db_user, $db_pass ); +} - for $item (@Templates) { - my $new_entry = new RT::Template($CurrentUser); - my $return = $new_entry->Create(%$item); - print $return. "."; - } - print "done.\n"; - } - if ( @Scrips ) { - print "Creating scrips..."; - - for $item (@Scrips) { - my $new_entry = new RT::Scrip($CurrentUser); - my ( $return, $msg ) = $new_entry->Create(%$item); - if ( $return ) { - print $return. "."; - } - else { - print "(Error: $msg)\n"; - } - } - print "done.\n"; - } - if ( @Attributes ) { - print "Creating predefined searches..."; - my $sys = RT::System->new($CurrentUser); - - for $item (@Attributes) { - my $obj = delete $item->{Object}; # XXX: make this something loadable - $obj ||= $sys; - my ( $return, $msg ) = $obj->AddAttribute (%$item); - if ( $return ) { - print $return. "."; - } - else { - print "(Error: $msg)\n"; - } +sub _get_dbh { + my ($dsn, $user, $pass) = @_; + my $dbh = DBI->connect( + $dsn, $user, $pass, + { RaiseError => 0, PrintError => 0 }, + ); + unless ( $dbh ) { + my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr; + if ( $args{'debug'} ) { + require Carp; Carp::confess( $msg ); + } else { + print STDERR $msg; exit -1; } - print "done.\n"; } - $RT::Handle->Disconnect() unless $RT::DatabaseType eq 'SQLite'; - print "Done setting up database content.\n"; + return $dbh; } -=head2 ACLEquivGroupId - -Given a userid, return that user's acl equivalence group - -=cut - -sub ACLEquivGroupId { - my $username = shift; - my $user = RT::User->new($RT::SystemUser); - $user->Load($username); - my $equiv_group = RT::Group->new($RT::SystemUser); - $equiv_group->LoadACLEquivalenceGroup($user); - return ( $equiv_group->Id ); +sub _yesno { + print "Proceed [y/N]:"; + my $x = scalar(<STDIN>); + $x =~ /^y/i; } sub help { @@ -674,25 +427,39 @@ sub help { $0: Set up RT's database ---action init Initialize the database - drop Drop the database. - This will ERASE ALL YOUR DATA - insert Insert data into RT's database. - By default, will use RT's installation data. - To use a local or supplementary datafile, specify it - using the '--datafile' option below. +--action init Initialize the database. This is combination of + multiple actions listed below. Create DB, schema, + setup acl, insert core data and initial data. + + upgrade Apply all needed schema/acl/content updates (will ask + for version to upgrade from) + + create Create the database. + + drop Drop the database. + This will ERASE ALL YOUR DATA + + schema Initialize only the database schema + To use a local or supplementary datafile, specify it + using the '--datadir' option below. + + acl Initialize only the database ACLs + To use a local or supplementary datafile, specify it + using the '--datadir' option below. + + coredata Insert data into RT's database. This data is required + for normal functioning of any RT instance. - acl Initialize only the database ACLs - To use a local or supplementary datafile, specify it - using the '--datadir' option below. + insert Insert data into RT's database. + By default, will use RT's installation data. + To use a local or supplementary datafile, specify it + using the '--datafile' option below. - schema Initialize only the database schema - To use a local or supplementary datafile, specify it - using the '--datadir' option below. +Several actions can be combined using comma separated list. --datafile /path/to/datafile --datadir /path/to/ Used to specify a path to find the local - database schema and acls to be installed. + database schema and acls to be installed. --dba dba's username diff --git a/rt/sbin/rt-setup-database.in b/rt/sbin/rt-setup-database.in index f134f5b..a51076f 100644 --- a/rt/sbin/rt-setup-database.in +++ b/rt/sbin/rt-setup-database.in @@ -1,9 +1,9 @@ -#!@PERL@ -w +#!@PERL@ # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -47,41 +47,56 @@ # # END BPS TAGGED BLOCK }}} use strict; -use vars qw($PROMPT $VERSION $Handle $Nobody $SystemUser $item); -use vars - qw(@Groups @Users @ACL @Queues @ScripActions @ScripConditions @Templates @CustomFields @Scrips @Attributes); +use warnings; + +use vars qw($Nobody $SystemUser $item); -use lib "@LOCAL_LIB_PATH@"; -use lib "@RT_LIB_PATH@"; +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} #This drags in RT's config.pm # We do it in a begin block because RT::Handle needs to know the type to do its # inheritance -use RT; -use Carp; -use RT::User; -use RT::CurrentUser; -use RT::Template; -use RT::ScripAction; -use RT::ACE; -use RT::Group; -use RT::User; -use RT::Queue; -use RT::ScripCondition; -use RT::CustomField; -use RT::Scrip; - -RT::LoadConfig(); +BEGIN { + use RT; + RT::LoadConfig(); + RT::InitClasses(); +} + use Term::ReadKey; use Getopt::Long; -my %args; +$| = 1; # unbuffer all output. +my %args; GetOptions( \%args, - 'prompt-for-dba-password', 'force', 'debug', - 'action=s', 'dba=s', 'dba-password=s', 'datafile=s', - 'datadir=s' + 'action=s', + 'force', 'debug', + 'dba=s', 'dba-password=s', 'prompt-for-dba-password', + 'datafile=s', 'datadir=s' ); unless ( $args{'action'} ) { @@ -89,583 +104,321 @@ unless ( $args{'action'} ) { exit(-1); } -$| = 1; #unbuffer that output. - -require RT::Handle; -my $Handle = RT::Handle->new($RT::DatabaseType); -$Handle->BuildDSN; -my $dbh; - -if ( $args{'prompt-for-dba-password'} ) { - $args{'dba-password'} = get_dba_password(); - chomp( $args{'dba-password'} ); -} - -if ( $args{'action'} eq 'init' ) { - $dbh = DBI->connect( get_system_dsn(), $args{'dba'}, $args{'dba-password'} ) - || die "Failed to connect to " . get_system_dsn() . " as $args{'dba'}: $DBI::errstr"; - print "Now creating a database for RT.\n"; - if ( $RT::DatabaseType ne 'Oracle' || $args{'dba'} ne $RT::DatabaseUser ) { - create_db(); - } else { - print "...skipped as ".$args{'dba'} ." is not " . $RT::DatabaseUser . " or we're working with Oracle.\n"; - } - - if ( $RT::DatabaseType eq "mysql" ) { - # Check which version we're running - my ($version) = $dbh->selectrow_hashref("show variables like 'version'")->{Value} =~ /^(\d\.\d+)/; - print "*** Warning: RT is unsupported on MySQL versions before 4.0.x\n" if $version < 4; - - # MySQL must have InnoDB support - my $innodb = $dbh->selectrow_hashref("show variables like 'have_innodb'")->{Value}; - if ( $innodb eq "NO" ) { - die "RT requires that MySQL be compiled with InnoDB table support.\n". - "See http://dev.mysql.com/doc/mysql/en/InnoDB.html\n"; - } elsif ( $innodb eq "DISABLED" ) { - die "RT requires that MySQL InnoDB table support be enabled.\n". - ($version < 4 - ? "Add 'innodb_data_file_path=ibdata1:10M:autoextend' to the [mysqld] section of my.cnf\n" - : "Remove the 'skip-innodb' line from your my.cnf file, restart MySQL, and try again.\n"); - } - } - - # SQLite can't deal with the disconnect/reconnect - unless ( $RT::DatabaseType eq 'SQLite' ) { - - $dbh->disconnect; - - if ( $RT::DatabaseType eq "Oracle" ) { - $RT::DatabasePassword = $RT::DatabasePassword; #Warning avidance - $dbh = DBI->connect( $Handle->DSN, ${RT::DatabaseUser}, ${RT::DatabasePassword} ) || die $DBI::errstr; - } else { - $dbh = DBI->connect( $Handle->DSN, $args{'dba'}, $args{'dba-password'} ) || die $DBI::errstr; - } - } - print "Now populating database schema.\n"; - insert_schema(); - print "Now inserting database ACLs\n"; - insert_acl() unless $RT::DatabaseType eq 'Oracle'; - print "Now inserting RT core system objects\n"; - insert_initial_data(); - print "Now inserting RT data\n"; - insert_data( $RT::EtcPath . "/initialdata" ); -} -elsif ( $args{'action'} eq 'drop' ) { - unless ( $dbh = - DBI->connect( get_system_dsn(), $args{'dba'}, $args{'dba-password'} ) ) - { - warn $DBI::errstr; - warn "Database doesn't appear to exist. Aborting database drop."; - exit; - } - drop_db(); -} -elsif ( $args{'action'} eq 'insert' ) { - insert_data( $args{'datafile'} || ($args{'datadir'}."/content") ); -} -elsif ( $args{'action'} eq 'acl' ) { - $dbh = DBI->connect( $Handle->DSN, $args{'dba'}, $args{'dba-password'} ) - || die "Failed to connect to " . get_system_dsn() . " as $args{'dba'}: $DBI::errstr"; - insert_acl($args{'datadir'}); -} -elsif ( $args{'action'} eq 'schema' ) { - $dbh = DBI->connect( $Handle->DSN, $args{'dba'}, $args{'dba-password'} ) - || die "Failed to connect to " . get_system_dsn() . " as $args{'dba'}: $DBI::errstr"; - insert_schema($args{'datadir'}); -} -else { - print STDERR "$0 called with an invalid --action parameter\n"; +# check and setup @actions +my @actions = grep $_, split /,/, $args{'action'}; +if ( @actions > 1 && $args{'datafile'} ) { + print STDERR "You can not use --datafile option with multiple actions.\n"; exit(-1); } - -# {{{ sub insert_schema -sub insert_schema { - my $base_path = (shift || $RT::EtcPath); - my (@schema); - print "Creating database schema.\n"; - - my $schema_file = $base_path . "/schema." . $RT::DatabaseType; - if ( -f $schema_file ) { - open( SCHEMA, "<$schema_file" ) or die "Can't open $schema_file: $!"; - my @lines = <SCHEMA>; - - my $local_schema_file = $RT::LocalEtcPath . "/schema." . $RT::DatabaseType; - if (-f $local_schema_file) { - open( SCHEMA_LOCAL, "<$local_schema_file" ) - or die "Can't open $local_schema_file: $!"; - push @lines, ';;', <SCHEMA_LOCAL>; - } - - my $statement = ""; - foreach my $line (@lines) { - $line =~ s/\#.*//g; - $line =~ s/--.*//g; - $statement .= $line; - if ( $line =~ /;(\s*)$/ ) { - $statement =~ s/;(\s*)$//g; - push @schema, $statement; - $statement = ""; - } - } - - local $SIG{__WARN__} = sub {}; - my $is_local = 0; # local/etc/schema needs to be nonfatal. - $dbh->begin_work or die $dbh->errstr; - foreach my $statement (@schema) { - if ( $statement =~ /^\s*;$/ ) { $is_local = 1; next; } - - print STDERR "SQL: $statement\n" if defined $args{'debug'}; - my $sth = $dbh->prepare($statement) or die $dbh->errstr; - unless ( $sth->execute or $is_local ) { - die "Problem with statement:\n $statement\n" . $sth->errstr; - } - } - $dbh->commit or die $dbh->errstr; +foreach ( @actions ) { + unless ( /^(?:init|create|drop|schema|acl|coredata|insert|upgrade)$/ ) { + print STDERR "$0 called with an invalid --action parameter.\n"; + exit(-1); } - else { - die "Couldn't find schema file for " . $RT::DatabaseType . "\n"; + if ( /^(?:init|drop|upgrade)$/ && @actions > 1 ) { + print STDERR "You can not mix init, drop or upgrade action with any action.\n"; + exit(-1); } - print "Done setting up database schema.\n"; } -# }}} - -# {{{ sub drop_db -sub drop_db { - if ( $RT::DatabaseType eq 'Oracle' ) { - print <<END; - -To delete the tables and sequences of the RT Oracle database by running - \@etc/drop.Oracle -through SQLPlus. +# convert init to multiple actions +my $init = 0; +if ( $actions[0] eq 'init' ) { + @actions = qw(create schema acl coredata insert); + $init = 1; +} -END - return; - } - unless ( $args{'force'} ) { - print <<END; +# set options from environment +foreach my $key(qw(Type Host Name User Password)) { + next unless exists $ENV{ 'RT_DB_'. uc $key }; + print "Using Database$key from RT_DB_". uc($key) ." environment variable.\n"; + RT->Config->Set( "Database$key", $ENV{ 'RT_DB_'. uc $key }); +} -About to drop $RT::DatabaseType database $RT::DatabaseName on $RT::DatabaseHost. -WARNING: This will erase all data in $RT::DatabaseName. +my $db_type = RT->Config->Get('DatabaseType') || ''; +my $db_host = RT->Config->Get('DatabaseHost') || ''; +my $db_name = RT->Config->Get('DatabaseName') || ''; +my $db_user = RT->Config->Get('DatabaseUser') || ''; +my $db_pass = RT->Config->Get('DatabasePassword') || ''; -END - exit unless _yesno(); +# load it here to get error immidiatly if DB type is not supported +require RT::Handle; - } +if ( $db_type eq 'SQLite' && !File::Spec->file_name_is_absolute($db_name) ) { + $db_name = File::Spec->catfile($RT::VarPath, $db_name); + RT->Config->Set( DatabaseName => $db_name ); +} - print "Dropping $RT::DatabaseType database $RT::DatabaseName.\n"; +my $dba_user = $args{'dba'} || $ENV{'RT_DBA_USER'} || $db_user || ''; +my $dba_pass = $args{'dba-password'} || $ENV{'RT_DBA_PASSWORD'}; - if ( $RT::DatabaseType eq 'SQLite' ) { - unlink $RT::DatabaseName or warn $!; - return; - } - $dbh->do("Drop DATABASE $RT::DatabaseName") or warn $DBI::errstr; +if ( !$args{force} && ( !defined $dba_pass || $args{'prompt-for-dba-password'} ) ) { + $dba_pass = get_dba_password(); + chomp $dba_pass if defined($dba_pass); } -# }}} +print "Working with:\n" + ."Type:\t$db_type\nHost:\t$db_host\nName:\t$db_name\n" + ."User:\t$db_user\nDBA:\t$dba_user\n"; -# {{{ sub create_db -sub create_db { - print "Creating $RT::DatabaseType database $RT::DatabaseName.\n"; - if ( $RT::DatabaseType eq 'SQLite' ) { - return; - } - elsif ( $RT::DatabaseType eq 'Pg' ) { - $dbh->do("CREATE DATABASE $RT::DatabaseName WITH ENCODING='UNICODE'"); - if ( $DBI::errstr ) { - $dbh->do("CREATE DATABASE $RT::DatabaseName") || die $DBI::errstr; - } - } - elsif ( $RT::DatabaseType eq 'Oracle' ) { - insert_acl(); - } - elsif ( $RT::DatabaseType eq 'Informix' ) { - $ENV{DB_LOCALE} = 'en_us.utf8'; - $dbh->do("CREATE DATABASE $RT::DatabaseName WITH BUFFERED LOG"); - } - else { - $dbh->do("CREATE DATABASE $RT::DatabaseName") or die $DBI::errstr; - } +foreach my $action ( @actions ) { + no strict 'refs'; + my ($status, $msg) = *{ 'action_'. $action }{'CODE'}->( %args ); + error($action, $msg) unless $status; + print $msg ."\n" if $msg; + print "Done.\n"; } -# }}} +sub action_create { + my %args = @_; + my $dbh = get_system_dbh(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $dbh, 'pre' ); + return ($status, $msg) unless $status; -sub get_dba_password { - print "In order to create or update your RT database,"; - print "this script needs to connect to your " - . $RT::DatabaseType - . " instance on " - . $RT::DatabaseHost . " as " - . $args{'dba'} . ".\n"; - print "Please specify that user's database password below. If the user has no database\n"; - print "password, just press return.\n\n"; - print "Password: "; - ReadMode('noecho'); - my $password = ReadLine(0); - ReadMode('normal'); - print "\n"; - return ($password); + print "Now creating a $db_type database $db_name for RT.\n"; + return RT::Handle->CreateDatabase( $dbh ); } -# {{{ sub _yesno -sub _yesno { - print "Proceed [y/N]:"; - my $x = scalar(<STDIN>); - $x =~ /^y/i; -} +sub action_drop { + my %args = @_; -# }}} + print "Dropping $db_type database $db_name.\n"; + unless ( $args{'force'} ) { + print <<END; -# {{{ insert_acls -sub insert_acl { - my $base_path = (shift || $RT::EtcPath); +About to drop $db_type database $db_name on $db_host. +WARNING: This will erase all data in $db_name. - if ( $RT::DatabaseType =~ /^oracle$/i ) { - do $base_path . "/acl.Oracle" - || die "Couldn't find ACLS for Oracle\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^pg$/i ) { - do $base_path . "/acl.Pg" || die "Couldn't find ACLS for Pg\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^mysql$/i ) { - do $base_path . "/acl.mysql" - || die "Couldn't find ACLS for mysql in $base_path\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^Sybase$/i ) { - do $base_path . "/acl.Sybase" - || die "Couldn't find ACLS for Sybase in $base_path\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^informix$/i ) { - do $base_path . "/acl.Informix" - || die "Couldn't find ACLS for Informix in $base_path\n" . $@; - } - elsif ( $RT::DatabaseType =~ /^SQLite$/i ) { - return; - } - else { - die "Unknown RT database type"; +END + exit(-2) unless _yesno(); } - my @acl = acl($dbh); - foreach my $statement (@acl) { - print STDERR $statement if $args{'debug'}; - my $sth = $dbh->prepare($statement) or die $dbh->errstr; - unless ( $sth->execute ) { - die "Problem with statement:\n $statement\n" . $sth->errstr; - } - } - print "Done setting up database ACLs.\n"; + my $dbh = get_system_dbh(); + return RT::Handle->DropDatabase( $dbh ); } -# }}} - -=head2 get_system_dsn - -Returns a dsn suitable for database creates and drops -and user creates and drops - -=cut - -sub get_system_dsn { +sub action_schema { + my %args = @_; + my $dbh = get_admin_dbh(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $dbh, 'pre' ); + return ($status, $msg) unless $status; - my $dsn = $Handle->DSN; + print "Now populating database schema.\n"; + return RT::Handle->InsertSchema( $dbh, $args{'datafile'} || $args{'datadir'} ); +} - #with mysql, you want to connect sans database to funge things - if ( $RT::DatabaseType eq 'mysql' ) { - $dsn =~ s/dbname=$RT::DatabaseName//; +sub action_acl { + my %args = @_; + my $dbh = get_admin_dbh(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $dbh, 'pre' ); + return ($status, $msg) unless $status; - # with postgres, you want to connect to database1 - } - elsif ( $RT::DatabaseType eq 'Pg' ) { - $dsn =~ s/dbname=$RT::DatabaseName/dbname=template1/; - } - elsif ( $RT::DatabaseType eq 'Informix' ) { - # with Informix, you want to connect sans database: - $dsn =~ s/Informix:$RT::DatabaseName/Informix:/; - } - return $dsn; + print "Now inserting database ACLs\n"; + return RT::Handle->InsertACL( $dbh, $args{'datafile'} || $args{'datadir'} ); } -sub insert_initial_data { - +sub action_coredata { + my %args = @_; + $RT::Handle = new RT::Handle; + $RT::Handle->dbh( undef ); + RT::ConnectToDatabase(); RT::InitLogging(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $RT::Handle->dbh, 'pre' ); + return ($status, $msg) unless $status; - #connect to the db, for actual RT work - require RT::Handle; - $RT::Handle = RT::Handle->new(); - $RT::Handle->Connect(); - - #Put together a current user object so we can create a User object - my $CurrentUser = new RT::CurrentUser(); - - print "Checking for existing system user..."; - my $test_user = RT::User->new($CurrentUser); - $test_user->Load('RT_System'); - if ( $test_user->id ) { - print "found!\n\nYou appear to have a functional RT database.\n" - . "Exiting, so as not to clobber your existing data.\n"; - exit(-1); - - } - else { - print "not found. This appears to be a new installation.\n"; - } - - print "Creating system user..."; - my $RT_System = new RT::User($CurrentUser); - - my ( $val, $msg ) = $RT_System->_BootstrapCreate( - Name => 'RT_System', - RealName => 'The RT System itself', - Comments => -'Do not delete or modify this user. It is integral to RT\'s internal database structures', - Creator => '1', - LastUpdatedBy => '1', - ); - - unless ( $val ) { - print "$msg\n"; - exit(-1); - } - print "done.\n"; - $RT::Handle->Disconnect() unless $RT::DatabaseType eq 'SQLite'; + print "Now inserting RT core system objects\n"; + return $RT::Handle->InsertInitialData; +} +sub action_insert { + my %args = @_; + $RT::Handle = new RT::Handle; + RT::Init(); + my ($status, $msg) = RT::Handle->CheckCompatibility( $RT::Handle->dbh, 'pre' ); + return ($status, $msg) unless $status; + + print "Now inserting data\n"; + my $file = $args{'datafile'}; + $file = $RT::EtcPath . "/initialdata" if $init && !$file; + $file ||= $args{'datadir'}."/content"; + return $RT::Handle->InsertData( $file ); } -# load some sort of data into the database +sub action_upgrade { + my %args = @_; + my $base_dir = $args{'datadir'} || "./etc/upgrade"; + return (0, "Couldn't read dir '$base_dir' with upgrade data") + unless -d $base_dir || -r _; + + my $upgrading_from = undef; + do { + if ( defined $upgrading_from ) { + print "Doesn't match #.#.#: "; + } else { + print "Enter RT version you're upgrading from: "; + } + $upgrading_from = scalar <STDIN>; + chomp $upgrading_from; + $upgrading_from =~ s/\s+//g; + } while $upgrading_from !~ /^\d+\.\d+\.\d+$/; + + my $upgrading_to = $RT::VERSION; + return (0, "The current version $upgrading_to is lower than $upgrading_from") + if RT::Handle::cmp_version( $upgrading_from, $upgrading_to ) > 0; -sub insert_data { - my $datafile = shift; + return (1, "The version $upgrading_to you're upgrading to is up to date") + if RT::Handle::cmp_version( $upgrading_from, $upgrading_to ) == 0; - #Connect to the database and get RT::SystemUser and RT::Nobody loaded - RT::Init; + my @versions = get_versions_from_to($base_dir, $upgrading_from, $upgrading_to); - my $CurrentUser = RT::CurrentUser->new(); - $CurrentUser->LoadByName('RT_System'); + return (1, "No DB changes between $upgrading_from and $upgrading_to") + unless @versions; - if ( $datafile eq $RT::EtcPath . "/initialdata" ) { + print "\nGoing to apply following upgrades:\n"; + print map "* $_\n", @versions; - print "Creating Superuser ACL..."; + { + my $custom_upgrading_to = undef; + do { + if ( defined $custom_upgrading_to ) { + print "Doesn't match #.#.#: "; + } else { + print "\nEnter RT version if you want to stop upgrade at some point,\n"; + print " or leave it blank if you want apply above upgrades: "; + } + $custom_upgrading_to = scalar <STDIN>; + chomp $custom_upgrading_to; + $custom_upgrading_to =~ s/\s+//g; + last unless $custom_upgrading_to; + } while $custom_upgrading_to !~ /^\d+\.\d+\.\d+$/; + + if ( $custom_upgrading_to ) { + return ( + 0, "The version you entered ($custom_upgrading_to) is lower than\n" + ."version you're upgrading from ($upgrading_from)" + ) if RT::Handle::cmp_version( $upgrading_from, $custom_upgrading_to ) > 0; + + return (1, "The version you're upgrading to is up to date") + if RT::Handle::cmp_version( $upgrading_from, $custom_upgrading_to ) == 0; + + if ( RT::Handle::cmp_version( $RT::VERSION, $custom_upgrading_to ) < 0 ) { + print "Version you entered is greater than installed ($RT::VERSION).\n"; + _yesno() or exit(-2); + } + # ok, checked everything no let's refresh list + $upgrading_to = $custom_upgrading_to; + @versions = get_versions_from_to($base_dir, $upgrading_from, $upgrading_to); - my $superuser_ace = RT::ACE->new($CurrentUser); - $superuser_ace->_BootstrapCreate( - PrincipalId => ACLEquivGroupId( $CurrentUser->Id ), - PrincipalType => 'Group', - RightName => 'SuperUser', - ObjectType => 'RT::System', - ObjectId => '1' ); + return (1, "No DB changes between $upgrading_from and $upgrading_to") + unless @versions; - print "done.\n"; + print "\nGoing to apply following upgrades:\n"; + print map "* $_\n", @versions; + } } - # Slurp in stuff to insert from the datafile. Possible things to go in here:- - # @groups, @users, @acl, @queues, @ScripActions, @ScripConditions, @templates - - require $datafile - || die "Couldn't find initial data for import\n" . $@; + print "\nIT'S VERY IMPORTANT TO BACK UP BEFORE THIS STEP\n\n"; + _yesno() or exit(-2) unless $args{'force'}; - if ( @Groups ) { - print "Creating groups..."; - foreach $item (@Groups) { - my $new_entry = RT::Group->new($CurrentUser); - my ( $return, $msg ) = $new_entry->_Create(%$item); - print "(Error: $msg)" unless $return; - print $return. "."; + foreach my $v ( @versions ) { + print "Processing $v\n"; + my %tmp = (%args, datadir => "$base_dir/$v", datafile => undef); + if ( -e "$base_dir/$v/schema.$db_type" ) { + action_schema( %tmp ); } - print "done.\n"; - } - if ( @Users ) { - print "Creating users..."; - foreach $item (@Users) { - my $new_entry = new RT::User($CurrentUser); - my ( $return, $msg ) = $new_entry->Create(%$item); - print "(Error: $msg)" unless $return; - print $return. "."; + if ( -e "$base_dir/$v/acl.$db_type" ) { + action_acl( %tmp ); } - print "done.\n"; - } - if ( @Queues ) { - print "Creating queues..."; - for $item (@Queues) { - my $new_entry = new RT::Queue($CurrentUser); - my ( $return, $msg ) = $new_entry->Create(%$item); - print "(Error: $msg)" unless $return; - print $return. "."; + if ( -e "$base_dir/$v/content" ) { + action_insert( %tmp ); } - print "done.\n"; } - if ( @ACL ) { - print "Creating ACL..."; - for my $item (@ACL) { - - my ($princ, $object); - - # Global rights or Queue rights? - if ( $item->{'Queue'} ) { - $object = RT::Queue->new($CurrentUser); - $object->Load( $item->{'Queue'} ); - } else { - $object = $RT::System; - } - - # Group rights or user rights? - if ( $item->{'GroupDomain'} ) { - $princ = RT::Group->new($CurrentUser); - if ( $item->{'GroupDomain'} eq 'UserDefined' ) { - $princ->LoadUserDefinedGroup( $item->{'GroupId'} ); - } elsif ( $item->{'GroupDomain'} eq 'SystemInternal' ) { - $princ->LoadSystemInternalGroup( $item->{'GroupType'} ); - } elsif ( $item->{'GroupDomain'} eq 'RT::System-Role' ) { - $princ->LoadSystemRoleGroup( $item->{'GroupType'} ); - } elsif ( $item->{'GroupDomain'} eq 'RT::Queue-Role' && - $item->{'Queue'} ) - { - $princ->LoadQueueRoleGroup( Type => $item->{'GroupType'}, - Queue => $object->id); - } else { - $princ->Load( $item->{'GroupId'} ); - } - } else { - $princ = RT::User->new($CurrentUser); - $princ->Load( $item->{'UserId'} ); - } + return 1; +} - # Grant it - my ( $return, $msg ) = $princ->PrincipalObj->GrantRight( - Right => $item->{'Right'}, - Object => $object ); +sub get_versions_from_to { + my ($base_dir, $from, $to) = @_; - if ( $return ) { - print $return. "."; - } - else { - print $msg . "."; + opendir my $dh, $base_dir or die "couldn't open dir: $!"; + my @versions = grep -d "$base_dir/$_" && /\d+\.\d+\.\d+/, readdir $dh; + closedir $dh; - } + return + grep RT::Handle::cmp_version($_, $to) <= 0, + grep RT::Handle::cmp_version($_, $from) > 0, + sort RT::Handle::cmp_version @versions; +} - } - print "done.\n"; - } - if ( @CustomFields ) { - print "Creating custom fields..."; - for $item (@CustomFields) { - my $new_entry = new RT::CustomField($CurrentUser); - my $values = $item->{'Values'}; - delete $item->{'Values'}; - my ( $return, $msg ) = $new_entry->Create(%$item); - unless( $return ) { - print "(Error: $msg)\n"; - next; - } +sub error { + my ($action, $msg) = @_; + print STDERR "Couldn't finish '$action' step.\n\n"; + print STDERR "ERROR: $msg\n\n"; + exit(-1); +} - foreach my $value ( @{$values} ) { - my ( $eval, $emsg ) = $new_entry->AddValue(%$value); - print "(Error: $emsg)\n" unless $eval; - } +sub get_dba_password { + print "In order to create or update your RT database," + . " this script needs to connect to your " + . " $db_type instance on $db_host as $dba_user\n"; + print "Please specify that user's database password below. If the user has no database\n"; + print "password, just press return.\n\n"; + print "Password: "; + ReadMode('noecho'); + my $password = ReadLine(0); + ReadMode('normal'); + print "\n"; + return ($password); +} - if ( $item->{LookupType} && !exists $item->{'Queue'} ) { # enable by default - my $ocf = RT::ObjectCustomField->new($CurrentUser); - $ocf->Create( CustomField => $new_entry->Id ); - } +=head2 get_system_dbh - print "(Error: $msg)\n" unless $return; - print $return. "."; - } +Returns L<DBI> database handle connected to B<system> with DBA credentials. - print "done.\n"; - } +See also L<RT::Handle/SystemDSN>. - if ( @ScripActions ) { - print "Creating ScripActions..."; +=cut - for $item (@ScripActions) { - my $new_entry = RT::ScripAction->new($CurrentUser); - my ($return,$msg) = $new_entry->Create(%$item); - unless ($return) { - print "(Error: $msg)\n"; - next; - } - print $return. "."; - } +sub get_system_dbh { + return _get_dbh( RT::Handle->SystemDSN, $dba_user, $dba_pass ); +} - print "done.\n"; - } +sub get_admin_dbh { + return _get_dbh( RT::Handle->DSN, $dba_user, $dba_pass ); +} - if ( @ScripConditions ) { - print "Creating ScripConditions..."; +=head2 get_rt_dbh [USER, PASSWORD] - for $item (@ScripConditions) { - my $new_entry = RT::ScripCondition->new($CurrentUser); - my ($return,$msg) = $new_entry->Create(%$item); - unless ($return) { - print "(Error: $msg)\n"; - next; - } - print $return. "."; - } +Returns L<DBI> database handle connected to RT database, +you may specify credentials(USER and PASSWORD) to connect +with. By default connects with credentials from RT config. - print "done.\n"; - } +=cut - if ( @Templates ) { - print "Creating templates..."; +sub get_rt_dbh { + return _get_dbh( RT::Handle->DSN, $db_user, $db_pass ); +} - for $item (@Templates) { - my $new_entry = new RT::Template($CurrentUser); - my $return = $new_entry->Create(%$item); - print $return. "."; - } - print "done.\n"; - } - if ( @Scrips ) { - print "Creating scrips..."; - - for $item (@Scrips) { - my $new_entry = new RT::Scrip($CurrentUser); - my ( $return, $msg ) = $new_entry->Create(%$item); - if ( $return ) { - print $return. "."; - } - else { - print "(Error: $msg)\n"; - } - } - print "done.\n"; - } - if ( @Attributes ) { - print "Creating predefined searches..."; - my $sys = RT::System->new($CurrentUser); - - for $item (@Attributes) { - my $obj = delete $item->{Object}; # XXX: make this something loadable - $obj ||= $sys; - my ( $return, $msg ) = $obj->AddAttribute (%$item); - if ( $return ) { - print $return. "."; - } - else { - print "(Error: $msg)\n"; - } +sub _get_dbh { + my ($dsn, $user, $pass) = @_; + my $dbh = DBI->connect( + $dsn, $user, $pass, + { RaiseError => 0, PrintError => 0 }, + ); + unless ( $dbh ) { + my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr; + if ( $args{'debug'} ) { + require Carp; Carp::confess( $msg ); + } else { + print STDERR $msg; exit -1; } - print "done.\n"; } - $RT::Handle->Disconnect() unless $RT::DatabaseType eq 'SQLite'; - print "Done setting up database content.\n"; + return $dbh; } -=head2 ACLEquivGroupId - -Given a userid, return that user's acl equivalence group - -=cut - -sub ACLEquivGroupId { - my $username = shift; - my $user = RT::User->new($RT::SystemUser); - $user->Load($username); - my $equiv_group = RT::Group->new($RT::SystemUser); - $equiv_group->LoadACLEquivalenceGroup($user); - return ( $equiv_group->Id ); +sub _yesno { + print "Proceed [y/N]:"; + my $x = scalar(<STDIN>); + $x =~ /^y/i; } sub help { @@ -674,25 +427,39 @@ sub help { $0: Set up RT's database ---action init Initialize the database - drop Drop the database. - This will ERASE ALL YOUR DATA - insert Insert data into RT's database. - By default, will use RT's installation data. - To use a local or supplementary datafile, specify it - using the '--datafile' option below. +--action init Initialize the database. This is combination of + multiple actions listed below. Create DB, schema, + setup acl, insert core data and initial data. + + upgrade Apply all needed schema/acl/content updates (will ask + for version to upgrade from) + + create Create the database. + + drop Drop the database. + This will ERASE ALL YOUR DATA + + schema Initialize only the database schema + To use a local or supplementary datafile, specify it + using the '--datadir' option below. + + acl Initialize only the database ACLs + To use a local or supplementary datafile, specify it + using the '--datadir' option below. + + coredata Insert data into RT's database. This data is required + for normal functioning of any RT instance. - acl Initialize only the database ACLs - To use a local or supplementary datafile, specify it - using the '--datadir' option below. + insert Insert data into RT's database. + By default, will use RT's installation data. + To use a local or supplementary datafile, specify it + using the '--datafile' option below. - schema Initialize only the database schema - To use a local or supplementary datafile, specify it - using the '--datadir' option below. +Several actions can be combined using comma separated list. --datafile /path/to/datafile --datadir /path/to/ Used to specify a path to find the local - database schema and acls to be installed. + database schema and acls to be installed. --dba dba's username diff --git a/rt/sbin/rt-shredder b/rt/sbin/rt-shredder new file mode 100755 index 0000000..5fa4909 --- /dev/null +++ b/rt/sbin/rt-shredder @@ -0,0 +1,323 @@ +#!/usr/bin/perl +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +=head1 NAME + +rt-shredder - Script which wipe out tickets from RT DB + +=head1 SYNOPSIS + + rt-shredder --plugin list + rt-shredder --plugin help-Tickets + rt-shredder --plugin 'Tickets=query,Queue="general" and Status="deleted"' + + rt-shredder --sqldump unshred.sql --plugin ... + rt-shredder --force --plugin ... + +=head1 DESCRIPTION + +rt-shredder - is script that allow you to wipe out objects +from RT DB. This script uses API that L<RT::Shredder> module adds to RT. +Script can be used as example of usage of the shredder API. + +=head1 USAGE + +You can use several options to control which objects script +should wipeout. + +=head1 OPTIONS + +=head2 --sqldump <filename> + +Outputs INSERT queiries into file. This dump can be used to restore data +after wiping out. + +By default creates files +F<< <RT_home>/var/data/RT-Shredder/<ISO_date>-XXXX.sql >> + +=head2 --object (DEPRECATED) + +Option has been deprecated, use plugin C<Objects> instead. + +=head2 --plugin '<plugin name>[=<arg>,<val>[;<arg>,<val>]...]' + +You can use plugins to select RT objects with various conditions. +See also --plugin list and --plugin help options. + +=head2 --plugin list + +Output list of the available plugins. + +=head2 --plugin help-<plugin name> + +Outputs help for specified plugin. + +=head2 --force + +Script doesn't ask any questions. + +=head1 SEE ALSO + +L<RT::Shredder> + +=cut + +use strict; +use warnings FATAL => 'all'; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use RT::Shredder (); +use Getopt::Long qw(GetOptions); +use File::Spec (); + +use RT::Shredder::Plugin (); +# prefetch list of plugins +our %plugins = RT::Shredder::Plugin->List; + +our %opt; +parse_args(); + +RT::Shredder::Init( %opt ); +my $shredder = new RT::Shredder; + +{ + my $plugin = eval { $shredder->AddDumpPlugin( Arguments => { + file_name => $opt{'sqldump'}, + from_storage => 0, + } ) }; + if( $@ ) { + print STDERR "ERROR: Couldn't open SQL dump file: $@\n"; + exit 1 if $opt{'sqldump'}; + + print STDERR "WARNING: It's strongly recommended to use '--sqldump <filename>' option\n"; + unless( $opt{'force'} ) { + exit 0 unless prompt_yN( "Do you want to proceed?" ); + } + } else { + print "SQL dump file is '". $plugin->FileName ."'\n"; + } +} + +my @objs = process_plugins( $shredder ); +prompt_delete_objs( \@objs ) unless $opt{'force'}; + +$shredder->PutObjects( Objects => $_ ) foreach @objs; +eval { $shredder->WipeoutAll }; +if( $@ ) { + require RT::Shredder::Exceptions; + if( my $e = RT::Shredder::Exception::Info->caught ) { + print "\nERROR: $e\n\n"; + exit 1; + } + die $@; +} + +sub prompt_delete_objs +{ + my( $objs ) = @_; + unless( @$objs ) { + print "Objects list is empty, try refine search options\n"; + exit 0; + } + my $list = "Next ". scalar( @$objs ) ." objects would be deleted:\n"; + foreach my $o( @$objs ) { + $list .= "\t". $o->_AsString ." object\n"; + } + print $list; + exit(0) unless prompt_yN( "Do you want to proceed?" ); +} + +sub prompt_yN +{ + my $text = shift; + print "$text [y/N] "; + unless( <STDIN> =~ /^(?:y|yes)$/i ) { + return 0; + } + return 1; +} + +sub usage +{ + require RT::Shredder::POD; + RT::Shredder::POD::shredder_cli( $0, \*STDOUT ); + exit 1; +} + +sub parse_args +{ + my $tmp; + Getopt::Long::Configure( "pass_through" ); + my @objs = (); + if( GetOptions( 'object=s' => \@objs ) && @objs ) { + print STDERR "Option --object had been deprecated, use plugin 'Objects' instead\n"; + exit(1); + } + + my @plugins = (); + if( GetOptions( 'plugin=s' => \@plugins ) && @plugins ) { + $opt{'plugin'} = \@plugins; + foreach my $str( @plugins ) { + if( $str =~ /^\s*list\s*$/ ) { + show_plugin_list(); + } elsif( $str =~ /^\s*help-(\w+)\s*$/ ) { + show_plugin_help( $1 ); + } elsif( $str =~ /^(\w+)(=.*)?$/ && !$plugins{$1} ) { + print "Couldn't find plugin '$1'\n"; + show_plugin_list(); + } + } + } + + # other options make no sense without previouse + usage() unless keys %opt; + + if( GetOptions( 'force' => \$tmp ) && $tmp ) { + $opt{'force'}++; + } + $tmp = undef; + if( GetOptions( 'sqldump=s' => \$tmp ) && $tmp ) { + $opt{'sqldump'} = $tmp; + } + return; +} + +sub process_plugins +{ + my $shredder = shift; + + my @res; + foreach my $str( @{ $opt{'plugin'} } ) { + my $plugin = new RT::Shredder::Plugin; + my( $status, $msg ) = $plugin->LoadByString( $str ); + unless( $status ) { + print STDERR "Couldn't load plugin\n"; + print STDERR "Error: $msg\n"; + exit(1); + } + if ( lc $plugin->Type eq 'search' ) { + push @res, _process_search_plugin( $shredder, $plugin ); + } + elsif ( lc $plugin->Type eq 'dump' ) { + _process_dump_plugin( $shredder, $plugin ); + } + } + return RT::Shredder->CastObjectsToRecords( Objects => \@res ); +} + +sub _process_search_plugin { + my ($shredder, $plugin) = @_; + my ($status, @objs) = $plugin->Run; + unless( $status ) { + print STDERR "Couldn't run plugin\n"; + print STDERR "Error: $objs[1]\n"; + exit(1); + } + + my $msg; + ($status, $msg) = $plugin->SetResolvers( Shredder => $shredder ); + unless( $status ) { + print STDERR "Couldn't set conflicts resolver\n"; + print STDERR "Error: $msg\n"; + exit(1); + } + return @objs; +} + +sub _process_dump_plugin { + my ($shredder, $plugin) = @_; + $shredder->AddDumpPlugin( + Object => $plugin, + ); +} + +sub show_plugin_list +{ + print "Plugins list:\n"; + print "\t$_\n" foreach( grep !/^Base$/, keys %plugins ); + exit(1); +} + +sub show_plugin_help +{ + my( $name ) = @_; + require RT::Shredder::POD; + unless( $plugins{ $name } ) { + print "Couldn't find plugin '$name'\n"; + show_plugin_list(); + } + RT::Shredder::POD::plugin_cli( $plugins{'Base'}, \*STDOUT, 1 ); + RT::Shredder::POD::plugin_cli( $plugins{ $name }, \*STDOUT ); + exit(1); +} + +exit(0); diff --git a/rt/sbin/rt-shredder.in b/rt/sbin/rt-shredder.in new file mode 100755 index 0000000..bc91ef6 --- /dev/null +++ b/rt/sbin/rt-shredder.in @@ -0,0 +1,323 @@ +#!@PERL@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +=head1 NAME + +rt-shredder - Script which wipe out tickets from RT DB + +=head1 SYNOPSIS + + rt-shredder --plugin list + rt-shredder --plugin help-Tickets + rt-shredder --plugin 'Tickets=query,Queue="general" and Status="deleted"' + + rt-shredder --sqldump unshred.sql --plugin ... + rt-shredder --force --plugin ... + +=head1 DESCRIPTION + +rt-shredder - is script that allow you to wipe out objects +from RT DB. This script uses API that L<RT::Shredder> module adds to RT. +Script can be used as example of usage of the shredder API. + +=head1 USAGE + +You can use several options to control which objects script +should wipeout. + +=head1 OPTIONS + +=head2 --sqldump <filename> + +Outputs INSERT queiries into file. This dump can be used to restore data +after wiping out. + +By default creates files +F<< <RT_home>/var/data/RT-Shredder/<ISO_date>-XXXX.sql >> + +=head2 --object (DEPRECATED) + +Option has been deprecated, use plugin C<Objects> instead. + +=head2 --plugin '<plugin name>[=<arg>,<val>[;<arg>,<val>]...]' + +You can use plugins to select RT objects with various conditions. +See also --plugin list and --plugin help options. + +=head2 --plugin list + +Output list of the available plugins. + +=head2 --plugin help-<plugin name> + +Outputs help for specified plugin. + +=head2 --force + +Script doesn't ask any questions. + +=head1 SEE ALSO + +L<RT::Shredder> + +=cut + +use strict; +use warnings FATAL => 'all'; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use RT::Shredder (); +use Getopt::Long qw(GetOptions); +use File::Spec (); + +use RT::Shredder::Plugin (); +# prefetch list of plugins +our %plugins = RT::Shredder::Plugin->List; + +our %opt; +parse_args(); + +RT::Shredder::Init( %opt ); +my $shredder = new RT::Shredder; + +{ + my $plugin = eval { $shredder->AddDumpPlugin( Arguments => { + file_name => $opt{'sqldump'}, + from_storage => 0, + } ) }; + if( $@ ) { + print STDERR "ERROR: Couldn't open SQL dump file: $@\n"; + exit 1 if $opt{'sqldump'}; + + print STDERR "WARNING: It's strongly recommended to use '--sqldump <filename>' option\n"; + unless( $opt{'force'} ) { + exit 0 unless prompt_yN( "Do you want to proceed?" ); + } + } else { + print "SQL dump file is '". $plugin->FileName ."'\n"; + } +} + +my @objs = process_plugins( $shredder ); +prompt_delete_objs( \@objs ) unless $opt{'force'}; + +$shredder->PutObjects( Objects => $_ ) foreach @objs; +eval { $shredder->WipeoutAll }; +if( $@ ) { + require RT::Shredder::Exceptions; + if( my $e = RT::Shredder::Exception::Info->caught ) { + print "\nERROR: $e\n\n"; + exit 1; + } + die $@; +} + +sub prompt_delete_objs +{ + my( $objs ) = @_; + unless( @$objs ) { + print "Objects list is empty, try refine search options\n"; + exit 0; + } + my $list = "Next ". scalar( @$objs ) ." objects would be deleted:\n"; + foreach my $o( @$objs ) { + $list .= "\t". $o->_AsString ." object\n"; + } + print $list; + exit(0) unless prompt_yN( "Do you want to proceed?" ); +} + +sub prompt_yN +{ + my $text = shift; + print "$text [y/N] "; + unless( <STDIN> =~ /^(?:y|yes)$/i ) { + return 0; + } + return 1; +} + +sub usage +{ + require RT::Shredder::POD; + RT::Shredder::POD::shredder_cli( $0, \*STDOUT ); + exit 1; +} + +sub parse_args +{ + my $tmp; + Getopt::Long::Configure( "pass_through" ); + my @objs = (); + if( GetOptions( 'object=s' => \@objs ) && @objs ) { + print STDERR "Option --object had been deprecated, use plugin 'Objects' instead\n"; + exit(1); + } + + my @plugins = (); + if( GetOptions( 'plugin=s' => \@plugins ) && @plugins ) { + $opt{'plugin'} = \@plugins; + foreach my $str( @plugins ) { + if( $str =~ /^\s*list\s*$/ ) { + show_plugin_list(); + } elsif( $str =~ /^\s*help-(\w+)\s*$/ ) { + show_plugin_help( $1 ); + } elsif( $str =~ /^(\w+)(=.*)?$/ && !$plugins{$1} ) { + print "Couldn't find plugin '$1'\n"; + show_plugin_list(); + } + } + } + + # other options make no sense without previouse + usage() unless keys %opt; + + if( GetOptions( 'force' => \$tmp ) && $tmp ) { + $opt{'force'}++; + } + $tmp = undef; + if( GetOptions( 'sqldump=s' => \$tmp ) && $tmp ) { + $opt{'sqldump'} = $tmp; + } + return; +} + +sub process_plugins +{ + my $shredder = shift; + + my @res; + foreach my $str( @{ $opt{'plugin'} } ) { + my $plugin = new RT::Shredder::Plugin; + my( $status, $msg ) = $plugin->LoadByString( $str ); + unless( $status ) { + print STDERR "Couldn't load plugin\n"; + print STDERR "Error: $msg\n"; + exit(1); + } + if ( lc $plugin->Type eq 'search' ) { + push @res, _process_search_plugin( $shredder, $plugin ); + } + elsif ( lc $plugin->Type eq 'dump' ) { + _process_dump_plugin( $shredder, $plugin ); + } + } + return RT::Shredder->CastObjectsToRecords( Objects => \@res ); +} + +sub _process_search_plugin { + my ($shredder, $plugin) = @_; + my ($status, @objs) = $plugin->Run; + unless( $status ) { + print STDERR "Couldn't run plugin\n"; + print STDERR "Error: $objs[1]\n"; + exit(1); + } + + my $msg; + ($status, $msg) = $plugin->SetResolvers( Shredder => $shredder ); + unless( $status ) { + print STDERR "Couldn't set conflicts resolver\n"; + print STDERR "Error: $msg\n"; + exit(1); + } + return @objs; +} + +sub _process_dump_plugin { + my ($shredder, $plugin) = @_; + $shredder->AddDumpPlugin( + Object => $plugin, + ); +} + +sub show_plugin_list +{ + print "Plugins list:\n"; + print "\t$_\n" foreach( grep !/^Base$/, keys %plugins ); + exit(1); +} + +sub show_plugin_help +{ + my( $name ) = @_; + require RT::Shredder::POD; + unless( $plugins{ $name } ) { + print "Couldn't find plugin '$name'\n"; + show_plugin_list(); + } + RT::Shredder::POD::plugin_cli( $plugins{'Base'}, \*STDOUT, 1 ); + RT::Shredder::POD::plugin_cli( $plugins{ $name }, \*STDOUT ); + exit(1); +} + +exit(0); diff --git a/rt/sbin/rt-test-dependencies b/rt/sbin/rt-test-dependencies index fb14f84..a1fed19 100644 --- a/rt/sbin/rt-test-dependencies +++ b/rt/sbin/rt-test-dependencies @@ -2,8 +2,8 @@ # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -64,14 +64,24 @@ GetOptions( 'with-SPEEDYCGI', 'with-MODPERL1', 'with-MODPERL2', 'with-DEV', 'with-STANDALONE', + + 'with-GPG', + 'with-ICAL', + 'with-SMTP', + 'with-GRAPHVIZ', + 'with-GD', + 'with-DASHBOARDS', + 'download=s', - 'repository=s' + 'repository=s', + 'list-deps' ); unless (keys %args) { help(); - exit(0); + exit(1); } + # Set up defaults my %default = ( 'with-MASON' => 1, @@ -79,11 +89,16 @@ my %default = ( 'with-CLI' => 1, 'with-MAILGATE' => 1, 'with-DEV' => 0, - 'with-STANDALONE' => 0, + 'with-STANDALONE' => 1, + 'with-GPG' => 1, + 'with-ICAL' => 1, + 'with-SMTP' => 1, + 'with-GRAPHVIZ' => 0, + 'with-GD' => 1, + 'with-DASHBOARDS' => 1 ); $args{$_} = $default{$_} foreach grep !exists $args{$_}, keys %default; - { my $section; my %always_show_sections = ( @@ -94,35 +109,53 @@ $args{$_} = $default{$_} foreach grep !exists $args{$_}, keys %default; sub section { my $s = shift; $section = $s; - print "$s:\n"; + print "$s:\n" unless $args{'list-deps'}; } - my $any_missing = 0; - sub found { + sub print_found { my $msg = shift; my $test = shift; my $extra = shift; - - $any_missing = 1 unless $test; - if ($args{'v'} or not $test or $always_show_sections{$section}) { - print "\t$msg..."; - print $test ? "found" : "MISSING"; - print "\n"; + + unless ( $args{'list-deps'} ) { + if ( $args{'v'} or not $test or $always_show_sections{$section} ) { + print "\t$msg ..."; + print $test ? "found" : "MISSING"; + print "\n"; + } + + print "\t\t$extra\n" if defined $extra; } - - print "\t\t$extra\n" if defined $extra; } +} - sub conclude { - if ($any_missing) { - print "\nSOMETHING WAS MISSING!\n"; - exit 1; - } else { - print "\nEverything was found.\n"; +sub conclude { + my %missing_by_type = @_; + + unless ( $args{'list-deps'} ) { + unless ( keys %missing_by_type ) { + print "\nAll dependencies have been found.\n"; + return; + } + + print "\nSOME DEPENDENCIES WERE MISSING.\n"; + + for my $type ( keys %missing_by_type ) { + my $missing = $missing_by_type{$type}; + + print "$type missing dependencies:\n"; + for my $name ( keys %$missing ) { + my $module = $missing->{$name}; + my $version = $module->{version}; + print_found( $name . ( $version ? " >= $version" : "" ), + 0, $module->{error} ); + } + } + exit 1; } - } } + sub help { print <<'.'; @@ -130,22 +163,22 @@ sub help { By default, testdeps determine whether you have installed all the perl modules RT needs to run. - --install Install missing modules + --install Install missing modules The following switches will tell the tool to check for specific dependencies - --with-mysql Database interface for MySQL - --with-postgresql Database interface for PostgreSQL - --with-sqlite Database interface and driver for SQLite (unsupported) - --with-oracle Database interface for oracle (unsupported) + --with-mysql Database interface for MySQL + --with-postgresql Database interface for PostgreSQL + --with-oracle Database interface for Oracle + --with-sqlite Database interface and driver for SQLite (unsupported) - --with-standalone Libraries needed to support the standalone simple pure perl server - --with-fastcgi Libraries needed to support the fastcgi handler - --with-speedycgi Libraries needed to support the speedycgi handler - --with-modperl1 Libraries needed to support the modperl 1 handler - --with-modperl2 Libraries needed to support the modperl 2 handler + --with-standalone Libraries needed to support the standalone simple pure perl server + --with-fastcgi Libraries needed to support the fastcgi handler + --with-speedycgi Libraries needed to support the speedycgi handler + --with-modperl1 Libraries needed to support the modperl 1 handler + --with-modperl2 Libraries needed to support the modperl 2 handler - --with-dev Tools needed for RT development + --with-dev Tools needed for RT development You can also specify -v or --verbose to list the status of all dependencies, rather than just the missing ones. @@ -175,54 +208,55 @@ Digest::base Digest::MD5 2.27 DBI 1.37 Class::ReturnValue 0.40 -Date::Format -DBIx::SearchBuilder 1.53 -Text::Template +DBIx::SearchBuilder 1.54 +Text::Template 1.44 +File::ShareDir File::Spec 0.8 HTML::Entities HTML::Scrubber 0.08 Log::Dispatch 2.0 +Sys::Syslog 0.16 Locale::Maketext 1.06 Locale::Maketext::Lexicon 0.32 Locale::Maketext::Fuzzy -MIME::Entity 5.108 +MIME::Entity 5.425 Mail::Mailer 1.57 -Net::SMTP +Email::Address Text::Wrapper Time::ParseDate Time::HiRes -File::Temp -Text::Autoformat +File::Temp 0.18 Text::Quoted 2.02 Tree::Simple 1.04 +UNIVERSAL::require Regexp::Common Scalar::Util -Module::Versions::Report 1.03 +Module::Versions::Report 1.05 Cache::Simple::TimedExpiry -UNIVERSAL::require Calendar::Simple +Encode 2.21 CSS::Squish 0.06 +File::Glob Devel::StackTrace 1.19 . $deps{'MASON'} = [ text_to_hash( << '.') ]; -HTML::Mason 1.23 +HTML::Mason 1.36 Errno Digest::MD5 2.27 CGI::Cookie 1.20 Storable 2.08 Apache::Session 1.53 XML::RSS 1.05 -GD -GD::Graph -GD::Text Text::WikiFormat 0.76 CSS::Squish 0.06 +Devel::StackTrace 1.19 . $deps{'STANDALONE'} = [ text_to_hash( << '.') ]; -HTTP::Server::Simple 0.07 +HTTP::Server::Simple 0.34 HTTP::Server::Simple::Mason 0.09 +Net::Server . $deps{'MAILGATE'} = [ text_to_hash( << '.') ]; @@ -243,48 +277,58 @@ Term::ReadKey . $deps{'DEV'} = [ text_to_hash( << '.') ]; -Test::Inline -Apache::Test HTML::Form HTML::TokeParser WWW::Mechanize Test::WWW::Mechanize 1.04 Module::Refresh 0.03 -Test::Expect 0.30 +Test::Expect 0.31 XML::Simple File::Find +Test::Deep 0 # needed for shredder tests +String::ShellQuote 0 # needed for gnupg-incoming.t +Test::HTTP::Server::Simple 0.09 +Test::HTTP::Server::Simple::StashWarnings 0.02 +Log::Dispatch::Perl +Test::Warn +Test::Builder 0.77 # needed to fix TODO test +IPC::Run3 +Test::MockTime +HTTP::Server::Simple::Mason 0.13 . $deps{'FASTCGI'} = [ text_to_hash( << '.') ]; -CGI 2.92 +CGI 3.38 FCGI CGI::Fast . $deps{'SPEEDYCGI'} = [ text_to_hash( << '.') ]; -CGI 2.92 +CGI 3.38 CGI::SpeedyCGI . $deps{'MODPERL1'} = [ text_to_hash( << '.') ]; -CGI 2.92 +CGI 3.38 Apache::Request Apache::DBI 0.92 . $deps{'MODPERL2'} = [ text_to_hash( << '.') ]; -CGI 3.10 +CGI 3.38 Apache::DBI -HTML::Mason 1.31 +HTML::Mason 1.36 . $deps{'MYSQL'} = [ text_to_hash( << '.') ]; DBD::mysql 2.1018 . + $deps{'ORACLE'} = [ text_to_hash( << '.') ]; DBD::Oracle . + $deps{'POSTGRESQL'} = [ text_to_hash( << '.') ]; DBD::Pg 1.43 . @@ -293,6 +337,36 @@ $deps{'SQLITE'} = [ text_to_hash( << '.') ]; DBD::SQLite 1.00 . +$deps{'GPG'} = [ text_to_hash( << '.') ]; +GnuPG::Interface +PerlIO::eol +. + +$deps{'ICAL'} = [ text_to_hash( << '.') ]; +Data::ICal +. + +$deps{'SMTP'} = [ text_to_hash( << '.') ]; +Net::SMTP +. + +$deps{'DASHBOARDS'} = [ text_to_hash( << '.') ]; +HTML::RewriteAttributes 0.02 +MIME::Types +. + +$deps{'GRAPHVIZ'} = [ text_to_hash( << '.') ]; +GraphViz +IPC::Run +IPC::Run::SafeHandles +. + +$deps{'GD'} = [ text_to_hash( << '.') ]; +GD +GD::Graph +GD::Text +. + if ($args{'download'}) { download_mods(); @@ -303,7 +377,7 @@ check_perl_version(); check_users(); - +my %Missing_By_Type = (); foreach my $type (sort grep $args{$_}, keys %args) { next unless ($type =~ /^with-(.*?)$/); @@ -312,39 +386,58 @@ foreach my $type (sort grep $args{$_}, keys %args) { my @missing; my @deps = @{ $deps{$type} }; - while (@deps) { - my $module = shift @deps; - my $version = shift @deps; - my $ret = test_dep($module, $version); - push @missing, $module, $version unless $ret; - } + my %missing = test_deps(@deps); + if ( $args{'install'} ) { - while( @missing ) { - resolve_dep(shift @missing, shift @missing); + for my $module (keys %missing) { + resolve_dep($module, $missing{$module}{version}); + delete $missing{$module} if test_dep($module, $missing{$module}{version}); } } + + $Missing_By_Type{$type} = \%missing if keys %missing; } -conclude(); +conclude(%Missing_By_Type); + +sub test_deps { + my @deps = @_; + + my %missing; + while(@deps) { + my $module = shift @deps; + my $version = shift @deps; + my($test, $error) = test_dep($module, $version); + my $msg = $module . ($version ? " >= $version" : ''); + print_found($msg, $test, $error); + + $missing{$module} = { version => $version, error => $error } unless $test; + } + + return %missing; +} sub test_dep { my $module = shift; my $version = shift; - eval "use $module $version ()"; - if ($@) { - my $error = $@; - $error =~ s/\n(.*)$//s; - undef $error unless $error =~ /this is only/; - found("$module $version", 0, $error); - - return undef; - } else { - my $msg = "$module"; - $msg .= " >=$version" if $version; - found($msg, 1); - return 1; + if ( $args{'list-deps'} ) { + print $module, ': ', $version || 0, "\n"; + } + else { + eval "use $module $version ()"; + if ($@) { + my $error = $@; + $error =~ s/\n(.*)$//s; + $error =~ s/at \(eval \d+\) line \d+\.$//; + undef $error unless $error =~ /this is only/; + + return ( 0, $error ); + } + else { + return 1; + } } } @@ -366,8 +459,8 @@ sub resolve_dep { } unless ( $configured ) { print <<END; -You didn't configure CPAN shell yet. -Please run `/usr/bin/perl -MCPAN -e shell` tool and configure it. +You haven't configured the CPAN shell yet. +Please run `/usr/bin/perl -MCPAN -e shell` to configure it. END exit(1); } @@ -459,21 +552,21 @@ sub check_perl_version { section("perl"); eval {require 5.008003}; if ($@) { - found("5.8.3", 0,"RT is known to be non-functional on versions of perl older than 5.8.3. Please upgrade to 5.8.3 or newer."); + print_found("5.8.3", 0,"RT is known to be non-functional on versions of perl older than 5.8.3. Please upgrade to 5.8.3 or newer."); exit(1); } else { - found( ">=5.8.3($])", 1); + print_found( sprintf(">=5.8.3(%vd)", $^V), 1 ); } } sub check_users { section("users"); - found("rt group (www)", defined getgrnam("www")); - found("bin owner (root)", defined getpwnam("root")); - found("libs owner (root)", defined getpwnam("root")); - found("libs group (bin)", defined getgrnam("bin")); - found("web owner (www)", defined getpwnam("www")); - found("web group (www)", defined getgrnam("www")); + print_found("rt group (www)", defined getgrnam("www")); + print_found("bin owner (root)", defined getpwnam("root")); + print_found("libs owner (root)", defined getpwnam("root")); + print_found("libs group (bin)", defined getgrnam("bin")); + print_found("web owner (www)", defined getpwnam("www")); + print_found("web group (www)", defined getgrnam("www")); } diff --git a/rt/sbin/rt-test-dependencies.in b/rt/sbin/rt-test-dependencies.in index f978d7b..9819108 100644 --- a/rt/sbin/rt-test-dependencies.in +++ b/rt/sbin/rt-test-dependencies.in @@ -2,8 +2,8 @@ # BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC # <jesse@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -64,14 +64,24 @@ GetOptions( 'with-SPEEDYCGI', 'with-MODPERL1', 'with-MODPERL2', 'with-DEV', 'with-STANDALONE', + + 'with-GPG', + 'with-ICAL', + 'with-SMTP', + 'with-GRAPHVIZ', + 'with-GD', + 'with-DASHBOARDS', + 'download=s', - 'repository=s' + 'repository=s', + 'list-deps' ); unless (keys %args) { help(); - exit(0); + exit(1); } + # Set up defaults my %default = ( 'with-MASON' => 1, @@ -79,11 +89,16 @@ my %default = ( 'with-CLI' => 1, 'with-MAILGATE' => 1, 'with-DEV' => @RT_DEVEL_MODE@, - 'with-STANDALONE' => @RT_STANDALONE@, + 'with-STANDALONE' => 1, + 'with-GPG' => @RT_GPG@, + 'with-ICAL' => 1, + 'with-SMTP' => 1, + 'with-GRAPHVIZ' => @RT_GRAPHVIZ@, + 'with-GD' => @RT_GD@, + 'with-DASHBOARDS' => 1 ); $args{$_} = $default{$_} foreach grep !exists $args{$_}, keys %default; - { my $section; my %always_show_sections = ( @@ -94,35 +109,53 @@ $args{$_} = $default{$_} foreach grep !exists $args{$_}, keys %default; sub section { my $s = shift; $section = $s; - print "$s:\n"; + print "$s:\n" unless $args{'list-deps'}; } - my $any_missing = 0; - sub found { + sub print_found { my $msg = shift; my $test = shift; my $extra = shift; - - $any_missing = 1 unless $test; - if ($args{'v'} or not $test or $always_show_sections{$section}) { - print "\t$msg..."; - print $test ? "found" : "MISSING"; - print "\n"; + + unless ( $args{'list-deps'} ) { + if ( $args{'v'} or not $test or $always_show_sections{$section} ) { + print "\t$msg ..."; + print $test ? "found" : "MISSING"; + print "\n"; + } + + print "\t\t$extra\n" if defined $extra; } - - print "\t\t$extra\n" if defined $extra; } +} - sub conclude { - if ($any_missing) { - print "\nSOMETHING WAS MISSING!\n"; - exit 1; - } else { - print "\nEverything was found.\n"; +sub conclude { + my %missing_by_type = @_; + + unless ( $args{'list-deps'} ) { + unless ( keys %missing_by_type ) { + print "\nAll dependencies have been found.\n"; + return; + } + + print "\nSOME DEPENDENCIES WERE MISSING.\n"; + + for my $type ( keys %missing_by_type ) { + my $missing = $missing_by_type{$type}; + + print "$type missing dependencies:\n"; + for my $name ( keys %$missing ) { + my $module = $missing->{$name}; + my $version = $module->{version}; + print_found( $name . ( $version ? " >= $version" : "" ), + 0, $module->{error} ); + } + } + exit 1; } - } } + sub help { print <<'.'; @@ -130,22 +163,22 @@ sub help { By default, testdeps determine whether you have installed all the perl modules RT needs to run. - --install Install missing modules + --install Install missing modules The following switches will tell the tool to check for specific dependencies - --with-mysql Database interface for MySQL - --with-postgresql Database interface for PostgreSQL - --with-sqlite Database interface and driver for SQLite (unsupported) - --with-oracle Database interface for oracle (unsupported) + --with-mysql Database interface for MySQL + --with-postgresql Database interface for PostgreSQL + --with-oracle Database interface for Oracle + --with-sqlite Database interface and driver for SQLite (unsupported) - --with-standalone Libraries needed to support the standalone simple pure perl server - --with-fastcgi Libraries needed to support the fastcgi handler - --with-speedycgi Libraries needed to support the speedycgi handler - --with-modperl1 Libraries needed to support the modperl 1 handler - --with-modperl2 Libraries needed to support the modperl 2 handler + --with-standalone Libraries needed to support the standalone simple pure perl server + --with-fastcgi Libraries needed to support the fastcgi handler + --with-speedycgi Libraries needed to support the speedycgi handler + --with-modperl1 Libraries needed to support the modperl 1 handler + --with-modperl2 Libraries needed to support the modperl 2 handler - --with-dev Tools needed for RT development + --with-dev Tools needed for RT development You can also specify -v or --verbose to list the status of all dependencies, rather than just the missing ones. @@ -175,54 +208,55 @@ Digest::base Digest::MD5 2.27 DBI 1.37 Class::ReturnValue 0.40 -Date::Format -DBIx::SearchBuilder 1.53 -Text::Template +DBIx::SearchBuilder 1.54 +Text::Template 1.44 +File::ShareDir File::Spec 0.8 HTML::Entities HTML::Scrubber 0.08 Log::Dispatch 2.0 +Sys::Syslog 0.16 Locale::Maketext 1.06 Locale::Maketext::Lexicon 0.32 Locale::Maketext::Fuzzy -MIME::Entity 5.108 +MIME::Entity 5.425 Mail::Mailer 1.57 -Net::SMTP +Email::Address Text::Wrapper Time::ParseDate Time::HiRes -File::Temp -Text::Autoformat +File::Temp 0.18 Text::Quoted 2.02 Tree::Simple 1.04 +UNIVERSAL::require Regexp::Common Scalar::Util -Module::Versions::Report 1.03 +Module::Versions::Report 1.05 Cache::Simple::TimedExpiry -UNIVERSAL::require Calendar::Simple +Encode 2.21 CSS::Squish 0.06 +File::Glob Devel::StackTrace 1.19 . $deps{'MASON'} = [ text_to_hash( << '.') ]; -HTML::Mason 1.23 +HTML::Mason 1.36 Errno Digest::MD5 2.27 CGI::Cookie 1.20 Storable 2.08 Apache::Session 1.53 XML::RSS 1.05 -GD -GD::Graph -GD::Text Text::WikiFormat 0.76 CSS::Squish 0.06 +Devel::StackTrace 1.19 . $deps{'STANDALONE'} = [ text_to_hash( << '.') ]; -HTTP::Server::Simple 0.07 +HTTP::Server::Simple 0.34 HTTP::Server::Simple::Mason 0.09 +Net::Server . $deps{'MAILGATE'} = [ text_to_hash( << '.') ]; @@ -243,48 +277,58 @@ Term::ReadKey . $deps{'DEV'} = [ text_to_hash( << '.') ]; -Test::Inline -Apache::Test HTML::Form HTML::TokeParser WWW::Mechanize Test::WWW::Mechanize 1.04 Module::Refresh 0.03 -Test::Expect 0.30 +Test::Expect 0.31 XML::Simple File::Find +Test::Deep 0 # needed for shredder tests +String::ShellQuote 0 # needed for gnupg-incoming.t +Test::HTTP::Server::Simple 0.09 +Test::HTTP::Server::Simple::StashWarnings 0.02 +Log::Dispatch::Perl +Test::Warn +Test::Builder 0.77 # needed to fix TODO test +IPC::Run3 +Test::MockTime +HTTP::Server::Simple::Mason 0.13 . $deps{'FASTCGI'} = [ text_to_hash( << '.') ]; -CGI 2.92 +CGI 3.38 FCGI CGI::Fast . $deps{'SPEEDYCGI'} = [ text_to_hash( << '.') ]; -CGI 2.92 +CGI 3.38 CGI::SpeedyCGI . $deps{'MODPERL1'} = [ text_to_hash( << '.') ]; -CGI 2.92 +CGI 3.38 Apache::Request Apache::DBI 0.92 . $deps{'MODPERL2'} = [ text_to_hash( << '.') ]; -CGI 3.10 +CGI 3.38 Apache::DBI -HTML::Mason 1.31 +HTML::Mason 1.36 . $deps{'MYSQL'} = [ text_to_hash( << '.') ]; DBD::mysql 2.1018 . + $deps{'ORACLE'} = [ text_to_hash( << '.') ]; DBD::Oracle . + $deps{'POSTGRESQL'} = [ text_to_hash( << '.') ]; DBD::Pg 1.43 . @@ -293,6 +337,36 @@ $deps{'SQLITE'} = [ text_to_hash( << '.') ]; DBD::SQLite 1.00 . +$deps{'GPG'} = [ text_to_hash( << '.') ]; +GnuPG::Interface +PerlIO::eol +. + +$deps{'ICAL'} = [ text_to_hash( << '.') ]; +Data::ICal +. + +$deps{'SMTP'} = [ text_to_hash( << '.') ]; +Net::SMTP +. + +$deps{'DASHBOARDS'} = [ text_to_hash( << '.') ]; +HTML::RewriteAttributes 0.02 +MIME::Types +. + +$deps{'GRAPHVIZ'} = [ text_to_hash( << '.') ]; +GraphViz +IPC::Run +IPC::Run::SafeHandles +. + +$deps{'GD'} = [ text_to_hash( << '.') ]; +GD +GD::Graph +GD::Text +. + if ($args{'download'}) { download_mods(); @@ -303,7 +377,7 @@ check_perl_version(); check_users(); - +my %Missing_By_Type = (); foreach my $type (sort grep $args{$_}, keys %args) { next unless ($type =~ /^with-(.*?)$/); @@ -312,39 +386,58 @@ foreach my $type (sort grep $args{$_}, keys %args) { my @missing; my @deps = @{ $deps{$type} }; - while (@deps) { - my $module = shift @deps; - my $version = shift @deps; - my $ret = test_dep($module, $version); - push @missing, $module, $version unless $ret; - } + my %missing = test_deps(@deps); + if ( $args{'install'} ) { - while( @missing ) { - resolve_dep(shift @missing, shift @missing); + for my $module (keys %missing) { + resolve_dep($module, $missing{$module}{version}); + delete $missing{$module} if test_dep($module, $missing{$module}{version}); } } + + $Missing_By_Type{$type} = \%missing if keys %missing; } -conclude(); +conclude(%Missing_By_Type); + +sub test_deps { + my @deps = @_; + + my %missing; + while(@deps) { + my $module = shift @deps; + my $version = shift @deps; + my($test, $error) = test_dep($module, $version); + my $msg = $module . ($version ? " >= $version" : ''); + print_found($msg, $test, $error); + + $missing{$module} = { version => $version, error => $error } unless $test; + } + + return %missing; +} sub test_dep { my $module = shift; my $version = shift; - eval "use $module $version ()"; - if ($@) { - my $error = $@; - $error =~ s/\n(.*)$//s; - undef $error unless $error =~ /this is only/; - found("$module $version", 0, $error); - - return undef; - } else { - my $msg = "$module"; - $msg .= " >=$version" if $version; - found($msg, 1); - return 1; + if ( $args{'list-deps'} ) { + print $module, ': ', $version || 0, "\n"; + } + else { + eval "use $module $version ()"; + if ($@) { + my $error = $@; + $error =~ s/\n(.*)$//s; + $error =~ s/at \(eval \d+\) line \d+\.$//; + undef $error unless $error =~ /this is only/; + + return ( 0, $error ); + } + else { + return 1; + } } } @@ -366,8 +459,8 @@ sub resolve_dep { } unless ( $configured ) { print <<END; -You didn't configure CPAN shell yet. -Please run `@PERL@ -MCPAN -e shell` tool and configure it. +You haven't configured the CPAN shell yet. +Please run `@PERL@ -MCPAN -e shell` to configure it. END exit(1); } @@ -459,21 +552,21 @@ sub check_perl_version { section("perl"); eval {require 5.008003}; if ($@) { - found("5.8.3", 0,"RT is known to be non-functional on versions of perl older than 5.8.3. Please upgrade to 5.8.3 or newer."); + print_found("5.8.3", 0,"RT is known to be non-functional on versions of perl older than 5.8.3. Please upgrade to 5.8.3 or newer."); exit(1); } else { - found( ">=5.8.3($])", 1); + print_found( sprintf(">=5.8.3(%vd)", $^V), 1 ); } } sub check_users { section("users"); - found("rt group (@RTGROUP@)", defined getgrnam("@RTGROUP@")); - found("bin owner (@BIN_OWNER@)", defined getpwnam("@BIN_OWNER@")); - found("libs owner (@LIBS_OWNER@)", defined getpwnam("@LIBS_OWNER@")); - found("libs group (@LIBS_GROUP@)", defined getgrnam("@LIBS_GROUP@")); - found("web owner (@WEB_USER@)", defined getpwnam("@WEB_USER@")); - found("web group (@WEB_GROUP@)", defined getgrnam("@WEB_GROUP@")); + print_found("rt group (@RTGROUP@)", defined getgrnam("@RTGROUP@")); + print_found("bin owner (@BIN_OWNER@)", defined getpwnam("@BIN_OWNER@")); + print_found("libs owner (@LIBS_OWNER@)", defined getpwnam("@LIBS_OWNER@")); + print_found("libs group (@LIBS_GROUP@)", defined getgrnam("@LIBS_GROUP@")); + print_found("web owner (@WEB_USER@)", defined getpwnam("@WEB_USER@")); + print_found("web group (@WEB_GROUP@)", defined getgrnam("@WEB_GROUP@")); } diff --git a/rt/sbin/rt-validator b/rt/sbin/rt-validator new file mode 100755 index 0000000..2d6fc04 --- /dev/null +++ b/rt/sbin/rt-validator @@ -0,0 +1,1118 @@ +#!/usr/bin/perl +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use warnings; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("lib", "local/lib"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use Getopt::Long; +my %opt = (); +GetOptions( + \%opt, + 'check|c', + 'resolve', + 'force', + 'verbose|v', +); + +usage() unless $opt{'check'}; +usage_warning() if $opt{'resolve'} && !$opt{'force'}; + +sub usage { + print STDERR <<END; +Usage: $0 options + +Options: + + $0 --check + $0 --check --verbose + $0 --check --verbose --resolve + $0 --check --verbose --resolve --force + +--check - is mandatory argument, you can use -c, as well. +--verbose - print additional info to STDOUT +--resolve - enable resolver that can delete or create some records +--force - resolve without asking questions + +Description: + +This script checks integrity of records in RT's DB. May delete some invalid +records or ressurect accidentally deleted. + +END + exit 1; +} + +sub usage_warning { + print <<END; +This utility can fix some issues with DB by creating or updating. In some +cases there is no enough data to resurect a missing record, but records which +refers to a missing can be deleted. It's up to you to decide what to do. + +In any case it's highly recommended to have a backup before resolving anything. + +Press enter to continue. +END + <>; +} + +use RT; +RT::LoadConfig(); +RT::Init(); + +my $dbh = $RT::Handle->dbh; +my $db_type = RT->Config->Get('DatabaseType'); + +my %TYPE = ( + 'Transactions.Field' => 'text', + 'Transactions.OldValue' => 'text', + 'Transactions.NewValue' => 'text', +); + +my @models = qw( + ACE + Attachment + Attribute + CachedGroupMember + CustomField + CustomFieldValue + GroupMember + Group + Link + ObjectCustomField + ObjectCustomFieldValue + Principal + Queue + ScripAction + ScripCondition + Scrip + Template + Ticket + Transaction + User +); + +my %redo_on; +$redo_on{'Delete'} = { + ACL => [], + + Attributes => [], + + Links => [], + + CustomFields => [], + CustomFieldValues => [], + ObjectCustomFields => [], + ObjectCustomFieldValues => [], + + Queues => [], + + Scrips => [], + ScripActions => [], + ScripConditions => [], + Templates => [], + + Tickets => [ 'Tickets -> other', 'Tickets <-> Role Groups' ], + Transactions => [ 'Attachments -> other' ], + + Principals => ['User <-> ACL equivalence group', 'GMs -> Groups, Members' ], + Users => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'Principals -> Users' ], + Groups => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'CGM vs. GM', 'Principals -> Groups' ], + + GroupMembers => [ 'CGM vs. GM' ], + CachedGroupMembers => [ 'CGM vs. GM' ], +}; +$redo_on{'Create'} = { + Principals => ['User <-> ACL equivalence group', 'GMs -> Groups, Members' ], + Groups => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'CGM vs. GM' ], + GroupMembers => [ 'CGM vs. GM' ], + CachedGroupMembers => [ 'CGM vs. GM' ], +}; + +my %describe_cb; +%describe_cb = ( + Attachments => sub { + my $row = shift; + my $txn_id = $row->{transactionid}; + my $res = 'Attachment #'. $row->{id} .' -> Txn #'. $txn_id; + return $res .', '. describe( 'Transactions', $txn_id ); + }, + Transactions => sub { + my $row = shift; + return 'Transaction #'. $row->{id} .' -> object '. $row->{objecttype} .' #'. $row->{objectid}; + }, +); + +{ my %cache = (); +sub m2t($) { + my $model = shift; + return $cache{$model} if $cache{$model}; + my $class = "RT::$model"; + my $object = $class->new( $RT::SystemUser ); + return $cache{$model} = $object->Table; +} } + +my (@do_check, %redo_check); + +my @CHECKS; +foreach my $table ( qw(Users Groups) ) { + push @CHECKS, "$table -> Principals" => sub { + my $msg = "A record in $table refers not existing record in Principals." + ." The script can either create missing record in Principals" + ." or delete record in $table."; + my ($type) = ($table =~ /^(.*)s$/); + check_integrity( + $table, 'id' => 'Principals', 'id', + join_condition => 't.PrincipalType = ?', + bind_values => [ $type ], + action => sub { + my $id = shift; + return unless my $a = prompt_action( ['Delete', 'create'], $msg ); + + if ( $a eq 'd' ) { + delete_record( $table, $id ); + } + elsif ( $a eq 'c' ) { + my $principal_id = create_record( 'Principals', + id => $id, PrincipalType => $type, ObjectId => $id, Disabled => 0 + ); + } + else { + die "Unknown action '$a'"; + } + }, + ); + }; + + push @CHECKS, "Principals -> $table" => sub { + my $msg = "A record in Principals refers not existing record in $table." + ." In some cases it's possible to resurrect manually such records," + ." but this utility can only delete"; + + check_integrity( + 'Principals', 'id' => $table, 'id', + condition => 's.PrincipalType = ?', + bind_values => [ $table =~ /^(.*)s$/ ], + action => sub { + my $id = shift; + return unless prompt( 'Delete', $msg ); + + delete_record( 'Principals', $id ); + }, + ); + }; +} + +push @CHECKS, 'User <-> ACL equivalence group' => sub { + # from user to group + check_integrity( + 'Users', 'id' => 'Groups', 'Instance', + join_condition => 't.Domain = ? AND t.Type = ?', + bind_values => [ 'ACLEquivalence', 'UserEquiv' ], + action => sub { + my $id = shift; + return unless prompt( + 'Create', "Found an user that has no ACL equivalence group." + ); + + my $gid = create_record( 'Groups', + Domain => 'ACLEquivalence', Type => 'UserEquiv', Instance => $id, + ); + }, + ); + # from group to user + check_integrity( + 'Groups', 'Instance' => 'Users', 'id', + condition => 's.Domain = ? AND s.Type = ?', + bind_values => [ 'ACLEquivalence', 'UserEquiv' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found an user ACL equivalence group, but there is no user." + ); + + delete_record( 'Groups', $id ); + }, + ); + # one ACL equiv group for each user + check_uniqueness( + 'Groups', + columns => ['Instance'], + condition => '.Domain = ? AND .Type = ?', + bind_values => [ 'ACLEquivalence', 'UserEquiv' ], + ); +}; + +# check integrity of Queue role groups +push @CHECKS, 'Queues <-> Role Groups' => sub { + # XXX: we check only that there is at least one group for a queue + # from queue to group + check_integrity( + 'Queues', 'id' => 'Groups', 'Instance', + join_condition => 't.Domain = ?', + bind_values => [ 'RT::Queue-Role' ], + ); + # from group to queue + check_integrity( + 'Groups', 'Instance' => 'Queues', 'id', + condition => 's.Domain = ?', + bind_values => [ 'RT::Queue-Role' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found role group of not existant queue." + ); + + delete_record( 'Groups', $id ); + }, + ); +}; + +# check integrity of Ticket role groups +push @CHECKS, 'Tickets <-> Role Groups' => sub { + # XXX: we check only that there is at least one group for a queue + # from queue to group + check_integrity( + 'Tickets', 'id' => 'Groups', 'Instance', + join_condition => 't.Domain = ?', + bind_values => [ 'RT::Ticket-Role' ], + ); + # from group to ticket + check_integrity( + 'Groups', 'Instance' => 'Tickets', 'id', + condition => 's.Domain = ?', + bind_values => [ 'RT::Ticket-Role' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a role group of not existant ticket." + ); + + delete_record( 'Groups', $id ); + }, + ); +}; + +# additional CHECKS on groups +push @CHECKS, 'Role Groups (Instance, Type) uniqueness' => sub { + # Check that Domain, Instance and Type are unique + check_uniqueness( + 'Groups', + columns => ['Domain', 'Instance', 'Type'], + condition => '.Domain LIKE ?', + bind_values => [ '%-Role' ], + ); +}; + + +push @CHECKS, 'GMs -> Groups, Members' => sub { + my $msg = "A record in GroupMembers references an object that doesn't exist." + ." May be you deleted a group or principal directly from DB?" + ." Usually it's ok to delete such records."; + check_integrity( + 'GroupMembers', 'GroupId' => 'Groups', 'id', + action => sub { + my $id = shift; + return unless prompt( 'Delete', $msg ); + + delete_record( 'GroupMembers', $id ); + }, + ); + check_integrity( + 'GroupMembers', 'MemberId' => 'Principals', 'id', + action => sub { + my $id = shift; + return unless prompt( 'Delete', $msg ); + + delete_record( 'GroupMembers', $id ); + }, + ); +}; + +# CGM and GM +push @CHECKS, 'CGM vs. GM' => sub { + # all GM record should be duplicated in CGM + check_integrity( + GroupMembers => ['GroupId', 'MemberId'], + CachedGroupMembers => ['GroupId', 'MemberId'], + join_condition => 't.ImmediateParentId = t.GroupId AND t.Via = t.id', + action => sub { + my $id = shift; + return unless prompt( + 'Create', + "Found a record in GroupMembers that has no direct duplicate in CachedGroupMembers table." + ); + + my $gm = RT::GroupMember->new( $RT::SystemUser ); + $gm->Load( $id ); + die "Couldn't load GM record #$id" unless $gm->id; + my $cgm = create_record( 'CachedGroupMembers', + GroupId => $gm->GroupId, MemberId => $gm->MemberId, + ImmediateParentId => $gm->GroupId, Via => undef, + Disabled => 0, # XXX: we should check integrity of Disabled field + ); + update_records( "CachedGroupMembers", { id => $cgm }, { Via => $cgm } ); + }, + ); + # all first level CGM records should have a GM record + check_integrity( + CachedGroupMembers => ['GroupId', 'MemberId'], + GroupMembers => ['GroupId', 'MemberId'], + condition => 's.ImmediateParentId = s.GroupId AND s.Via = s.id AND s.GroupId != s.MemberId', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers for a (Group, Member) pair" + ." that doesn't exist in GroupMembers table." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + # each group should have a CGM record where MemberId == GroupId + check_integrity( + Groups => ['id', 'id'], + CachedGroupMembers => ['GroupId', 'MemberId'], + join_condition => 't.ImmediateParentId = t.GroupId AND t.Via = t.id', + action => sub { + my $id = shift; + return unless prompt( + 'Create', + "Found a record in Groups that has no direct" + ." duplicate in CachedGroupMembers table." + ); + + my $g = RT::Group->new( $RT::SystemUser ); + $g->Load( $id ); + die "Couldn't load group #$id" unless $g->id; + die "Loaded group by $id has id ". $g->id unless $g->id == $id; + my $cgm = create_record( 'CachedGroupMembers', + GroupId => $id, MemberId => $id, + ImmediateParentId => $id, Via => undef, + Disabled => $g->Disabled, + ); + update_records( "CachedGroupMembers", { id => $cgm }, { Via => $cgm } ); + }, + ); + + # and back, each record in CGM with MemberId == GroupId without exceptions + # should reference a group + check_integrity( + CachedGroupMembers => ['GroupId', 'MemberId'], + Groups => ['id', 'id'], + condition => "s.GroupId = s.MemberId", + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers for a group that doesn't exist." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + # Via + check_integrity( + CachedGroupMembers => 'Via', + CachedGroupMembers => 'id', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers with Via referencing not existing record." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + + # for every CGM where ImmediateParentId != GroupId there should be + # matching parent record (first level) + check_integrity( + CachedGroupMembers => ['ImmediateParentId', 'MemberId'], + CachedGroupMembers => ['GroupId', 'MemberId'], + join_condition => 't.Via = t.id', + condition => 's.ImmediateParentId != s.GroupId', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers that referencing not existant record in CachedGroupMembers table." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + + # for every CGM where ImmediateParentId != GroupId there should be + # matching "grand" parent record + check_integrity( + CachedGroupMembers => ['GroupId', 'ImmediateParentId', 'Via'], + CachedGroupMembers => ['GroupId', 'MemberId', 'id'], + condition => 's.ImmediateParentId != s.GroupId', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers that referencing not existant record in CachedGroupMembers table." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + + # CHECK recursive records: + # if we have CGM1 (G1,M1,V1,IP1) then for every GM2(G2, M2), where G2 == M1, + # we should have CGM3 where G3 = G1, M3 = M2, V3 = ID1, IP3 = M1 + { + my $query = <<END; +SELECT cgm1.GroupId, gm2.MemberId, cgm1.id AS Via, + cgm1.MemberId AS ImmediateParentId, cgm1.Disabled +FROM + CachedGroupMembers cgm1 + CROSS JOIN GroupMembers gm2 + LEFT JOIN CachedGroupMembers cgm3 ON ( + cgm3.GroupId = cgm1.GroupId + AND cgm3.MemberId = gm2.MemberId + AND cgm3.Via = cgm1.id + AND cgm3.ImmediateParentId = cgm1.MemberId ) +WHERE cgm1.GroupId != cgm1.MemberId +AND gm2.GroupId = cgm1.MemberId +AND cgm3.id IS NULL +END + + my $action = sub { + my %props = @_; + return unless prompt( + 'Create', + "Found records in CachedGroupMembers table without recursive duplicates." + ); + my $cgm = create_record( 'CachedGroupMembers', %props ); + }; + + my $sth = execute_query( $query ); + while ( my ($g, $m, $via, $ip, $dis) = $sth->fetchrow_array ) { + print STDERR "Principal #$m is member of #$ip when #$ip is member of #$g,"; + print STDERR " but there is no cached GM record that $m is member of #$g.\n"; + $action->( + GroupId => $g, MemberId => $m, Via => $via, + ImmediateParentId => $ip, Disabled => $dis, + ); + } + } +}; + +# Tickets +push @CHECKS, 'Tickets -> other' => sub { + check_integrity( + 'Tickets', 'EffectiveId' => 'Tickets', 'id', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a ticket that's been merged into a ticket that don't exist anymore." + ); + + delete_record( 'Tickets', $id ); + }, + ); + check_integrity( + 'Tickets', 'Queue' => 'Queues', 'id', + ); + check_integrity( + 'Tickets', 'Owner' => 'Users', 'id', + ); + # XXX: check that owner is only member of owner role group +}; + + +push @CHECKS, 'Transactions -> other' => sub { + foreach my $model ( @models ) { + check_integrity( + 'Transactions', 'ObjectId' => m2t($model), 'id', + condition => 's.ObjectType = ?', + bind_values => [ "RT::$model" ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction without object." + ); + + delete_record( 'Transactions', $id ); + }, + ); + } + # type = CustomField + check_integrity( + 'Transactions', 'Field' => 'CustomFields', 'id', + condition => 's.Type = ?', + bind_values => [ 'CustomField' ], + ); + # type = Take, Untake, Force, Steal or Give + check_integrity( + 'Transactions', 'OldValue' => 'Users', 'id', + condition => 's.Type IN (?, ?, ?, ?, ?)', + bind_values => [ qw(Take Untake Force Steal Give) ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction regarding changes of Owner," + ." but User with id stored in OldValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + check_integrity( + 'Transactions', 'NewValue' => 'Users', 'id', + condition => 's.Type IN (?, ?, ?, ?, ?)', + bind_values => [ qw(Take Untake Force Steal Give) ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction regarding changes of Owner," + ." but User with id stored in NewValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + # type = DelWatcher + check_integrity( + 'Transactions', 'OldValue' => 'Principals', 'id', + condition => 's.Type = ?', + bind_values => [ 'DelWatcher' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction describing watchers change," + ." but User with id stored in OldValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + # type = AddWatcher + check_integrity( + 'Transactions', 'NewValue' => 'Principals', 'id', + condition => 's.Type = ?', + bind_values => [ 'AddWatcher' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction describing watchers change," + ." but User with id stored in NewValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + +# XXX: Links need more love, uri is stored instead of id +# # type = DeleteLink +# check_integrity( +# 'Transactions', 'OldValue' => 'Links', 'id', +# condition => 's.Type = ?', +# bind_values => [ 'DeleteLink' ], +# ); +# # type = AddLink +# check_integrity( +# 'Transactions', 'NewValue' => 'Links', 'id', +# condition => 's.Type = ?', +# bind_values => [ 'AddLink' ], +# ); + + # type = Set, Field = Queue + check_integrity( + 'Transactions', 'NewValue' => 'Queues', 'id', + condition => 's.Type = ? AND s.Field = ?', + bind_values => [ 'Set', 'Queue' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction describing queue change," + ." but Queue with id stored in NewValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + check_integrity( + 'Transactions', 'OldValue' => 'Queues', 'id', + condition => 's.Type = ? AND s.Field = ?', + bind_values => [ 'Set', 'Queue' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction describing queue change," + ." but Queue with id stored in OldValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + # Reminders + check_integrity( + 'Transactions', 'NewValue' => 'Tickets', 'id', + join_condition => 't.Type = ?', + condition => 's.Type IN (?, ?, ?)', + bind_values => [ 'reminder', 'AddReminder', 'OpenReminder', 'ResolveReminder' ], + ); +}; + +# Attachments +push @CHECKS, 'Attachments -> other' => sub { + check_integrity( + Attachments => 'TransactionId', Transactions => 'id', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found an attachment without a transaction." + ); + delete_record( 'Attachments', $id ); + }, + ); + check_integrity( + Attachments => 'Parent', Attachments => 'id', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found an sub-attachment without its parent attachment." + ); + delete_record( 'Attachments', $id ); + }, + ); + check_integrity( + Attachments => 'Parent', + Attachments => 'id', + join_condition => 's.TransactionId = t.TransactionId', + ); +}; + +push @CHECKS, 'CustomFields and friends' => sub { + #XXX: ObjectCustomFields needs more love + check_integrity( + 'CustomFieldValues', 'CustomField' => 'CustomFields', 'id', + ); + check_integrity( + 'ObjectCustomFieldValues', 'CustomField' => 'CustomFields', 'id', + ); + foreach my $model ( @models ) { + check_integrity( + 'ObjectCustomFieldValues', 'ObjectId' => m2t($model), 'id', + condition => 's.ObjectType = ?', + bind_values => [ "RT::$model" ], + ); + } +}; + +push @CHECKS, Templates => sub { + check_integrity( + 'Templates', 'Queue' => 'Queues', 'id', + ); +}; + +push @CHECKS, Scrips => sub { + check_integrity( + 'Scrips', 'Queue' => 'Queues', 'id', + ); + check_integrity( + 'Scrips', 'ScripCondition' => 'ScripConditions', 'id', + ); + check_integrity( + 'Scrips', 'ScripAction' => 'ScripActions', 'id', + ); + check_integrity( + 'Scrips', 'Template' => 'Templates', 'id', + ); +}; + +push @CHECKS, Attributes => sub { + foreach my $model ( @models ) { + check_integrity( + 'Attributes', 'ObjectId' => m2t($model), 'id', + condition => 's.ObjectType = ?', + bind_values => [ "RT::$model" ], + ); + } +}; + +# Fix situations when Creator or LastUpdatedBy references ACL equivalence +# group of a user instead of user +push @CHECKS, 'FIX: LastUpdatedBy and Creator' => sub { + my %fix = (); + foreach my $model ( @models ) { + my $class = "RT::$model"; + my $object = $class->new( $RT::SystemUser ); + foreach my $column ( qw(LastUpdatedBy Creator) ) { + next unless $object->_Accessible( $column, 'auto' ); + + my $table = m2t($model); + my $query = <<END; +SELECT m.id, g.id, g.Instance +FROM + Groups g JOIN $table m ON g.id = m.$column +WHERE + g.Domain = ? + AND g.Type = ? +END + my $action = sub { + my ($gid, $uid) = @_; + return unless prompt( + 'Update', + "Looks like there were a bug in old versions of RT back in 2006\n" + ."that has been fixed. If other checks are ok then it's ok to update\n" + ."these records to point them to users instead of groups" + ); + $fix{ $table }{ $column }{ $gid } = $uid; + }; + + my $sth = execute_query( $query, 'ACLEquivalence', 'UserEquiv' ); + while ( my ($rid, $gid, $uid) = $sth->fetchrow_array ) { + print STDERR "Record #$rid in $table refers to ACL equivalence group #$gid of user #$uid"; + print STDERR " when must reference user.\n"; + $action->( $gid, $uid ); + if ( keys( %fix ) > 1000 ) { + $sth->finish; + last; + } + } + } + } + + if ( keys %fix ) { + foreach my $table ( keys %fix ) { + foreach my $column ( keys %{ $fix{ $table } } ) { + my $query = "UPDATE $table SET $column = ? WHERE $column = ?"; + while ( my ($gid, $uid) = each %{ $fix{ $table }{ $column } } ) { + update_records( $table, { $column => $gid }, { $column => $uid } ); + } + } + } + $redo_check{'FIX: LastUpdatedBy and Creator'} = 1; + } +}; + +push @CHECKS, 'LastUpdatedBy and Creator' => sub { + foreach my $model ( @models ) { + my $class = "RT::$model"; + my $object = $class->new( $RT::SystemUser ); + my $table = $object->Table; + foreach my $column ( qw(LastUpdatedBy Creator) ) { + next unless $object->_Accessible( $column, 'auto' ); + check_integrity( + $table, $column => 'Users', 'id', + action => sub { + my ($id, %prop) = @_; + return unless my $replace_with = prompt_integer( + 'Replace', + "Column $column should point to a user, but there is record #$id in table $table\n" + ."where it's not true. It's ok to replace these wrong references with id of any user.\n" + ."Note that id you enter is not checked. You can peak any user from your DB, but it's\n" + ."may be better to create a special user for this, for example 'user_that_has_been_deleted'\n" + ."or something like that.", + "$table.$column -> user #$prop{$column}" + ); + update_records( $table, { id => $id, $column => $prop{$column} }, { $column => $replace_with } ); + }, + ); + } + } +}; +my %CHECKS = @CHECKS; + +@do_check = do { my $i = 1; grep $i++%2, @CHECKS }; + +while ( my $check = shift @do_check ) { + $CHECKS{ $check }->(); + + foreach my $redo ( keys %redo_check ) { + die "check $redo doesn't exist" unless $CHECKS{ $redo }; + delete $redo_check{ $redo }; + next if grep $_ eq $redo, @do_check; # don't do twice + push @do_check, $redo; + } +} + +sub check_integrity { + my ($stable, @scols) = (shift, shift); + my ($ttable, @tcols) = (shift, shift); + my %args = @_; + + @scols = @{ $scols[0] } if ref $scols[0]; + @tcols = @{ $tcols[0] } if ref $tcols[0]; + + print "Checking integrity of $stable.{". join(', ', @scols) ."} => $ttable.{". join(', ', @tcols) ."}\n" + if $opt{'verbose'}; + + my $query = "SELECT s.id, ". join(', ', map "s.$_", @scols) + ." FROM $stable s LEFT JOIN $ttable t" + ." ON (". join( + ' AND ', map columns_eq_cond('s', $stable, $scols[$_] => 't', $ttable, $tcols[$_]), (0..(@scols-1)) + ) .")" + . ($args{'join_condition'}? " AND ( $args{'join_condition'} )": "") + ." WHERE t.id IS NULL" + ." AND ". join(' AND ', map "s.$_ IS NOT NULL", @scols); + + $query .= " AND ( $args{'condition'} )" if $args{'condition'}; + + my @binds = @{ $args{'bind_values'} || [] }; + if ( $tcols[0] eq 'id' && @tcols == 1 ) { + my $type = $TYPE{"$stable.$scols[0]"} || 'number'; + if ( $type eq 'number' ) { + $query .= " AND s.$scols[0] != ?" + } + elsif ( $type eq 'text' ) { + $query .= " AND s.$scols[0] NOT LIKE ?" + } + push @binds, 0; + } + + my $sth = execute_query( $query, @binds ); + while ( my ($sid, @set) = $sth->fetchrow_array ) { + print STDERR "Record #$sid in $stable references not existent record in $ttable\n"; + for ( my $i = 0; $i < @scols; $i++ ) { + print STDERR "\t$scols[$i] => '$set[$i]' => $tcols[$i]\n"; + } + print STDERR "\t". describe( $stable, $sid ) ."\n"; + $args{'action'}->( $sid, map { $scols[$_] => $set[$_] } (0 .. (@scols-1)) ) if $args{'action'}; + } +} + +sub describe { + my ($table, $id) = @_; + return '' unless my $cb = $describe_cb{ $table }; + + my $row = load_record( $table, $id ); + unless ( $row->{id} ) { + $table =~ s/s$//; + return "$table doesn't exist"; + } + return $cb->( $row ); +} + +sub columns_eq_cond { + my ($la, $lt, $lc, $ra, $rt, $rc) = @_; + my $ltype = $TYPE{"$lt.$lc"} || 'number'; + my $rtype = $TYPE{"$rt.$rc"} || 'number'; + return "$la.$lc = $ra.$rc" if $db_type ne 'Pg' || $ltype eq $rtype; + + if ( $rtype eq 'text' ) { + return "$ra.$rc LIKE CAST($la.$lc AS text)"; + } + elsif ( $ltype eq 'text' ) { + return "$la.$lc LIKE CAST($ra.$rc AS text)"; + } + else { die "don't know how to cast" } +} + +sub check_uniqueness { + my $on = shift; + my %args = @_; + + my @columns = @{ $args{'columns'} }; + + print "Checking uniqueness of ( ", join(', ', map "'$_'", @columns )," ) in table '$on'\n" + if $opt{'versbose'}; + + my ($scond, $tcond); + if ( $scond = $tcond = $args{'condition'} ) { + $scond =~ s/(\s|^)\./$1s./g; + $tcond =~ s/(\s|^)\./$1t./g; + } + + my $query = "SELECT s.id, t.id, ". join(', ', map "s.$_", @columns) + ." FROM $on s LEFT JOIN $on t " + ." ON s.id != t.id AND ". join(' AND ', map "s.$_ = t.$_", @columns) + . ($tcond? " AND ( $tcond )": "") + ." WHERE t.id IS NOT NULL " + ." AND ". join(' AND ', map "s.$_ IS NOT NULL", @columns); + $query .= " AND ( $scond )" if $scond; + + my $sth = execute_query( + $query, + $args{'bind_values'}? (@{ $args{'bind_values'} }, @{ $args{'bind_values'} }): () + ); + while ( my ($sid, $tid, @set) = $sth->fetchrow_array ) { + print STDERR "Record #$tid in $on has the same set of values as $sid\n"; + for ( my $i = 0; $i < @columns; $i++ ) { + print STDERR "\t$columns[$i] => '$set[$i]'\n"; + } + } +} + +sub load_record { + my ($table, $id) = @_; + my $sth = execute_query( "SELECT * FROM $table WHERE id = ?", $id ); + return $sth->fetchrow_hashref('NAME_lc'); +} + +sub delete_record { + my ($table, $id) = (@_); + print "Deleting record #$id in $table\n" if $opt{'verbose'}; + my $query = "DELETE FROM $table WHERE id = ?"; + $redo_check{ $_ } = 1 foreach @{ $redo_on{'Delete'}{ $table } || [] }; + return execute_query( $query, $id ); +} + +sub create_record { + print "Creating a record in $_[0]\n" if $opt{'verbose'}; + $redo_check{ $_ } = 1 foreach @{ $redo_on{'Create'}{ $_[0] } || [] }; + return $RT::Handle->Insert( @_ ); +} + +sub update_records { + my $table = shift; + my $where = shift; + my $what = shift; + + my (@where_cols, @where_binds); + while ( my ($k, $v) = each %$where ) { push @where_cols, $k; push @where_binds, $v; } + + my (@what_cols, @what_binds); + while ( my ($k, $v) = each %$what ) { push @what_cols, $k; push @what_binds, $v; } + + print "Updating record(s) in $table\n" if $opt{'verbose'}; + my $query = "UPDATE $table SET ". join(', ', map "$_ = ?", @what_cols) + ." WHERE ". join(' AND ', map "$_ = ?", @where_cols); + $redo_check{ $_ } = 1 foreach @{ $redo_on{'Update'}{ $table } || [] }; + return execute_query( $query, @what_binds, @where_binds ); +} + +sub execute_query { + my ($query, @binds) = @_; + + print "Executing query: $query\n\n" if $opt{'verbose'}; + + my $sth = $dbh->prepare( $query ) or die "couldn't prepare $query\n\tError: ". $dbh->errstr; + $sth->execute( @binds ) or die "couldn't execute $query\n\tError: ". $sth->errstr; + return $sth; +} + +{ my %cached_answer; +sub prompt { + my $action = shift; + my $msg = shift; + my $token = shift || join ':', caller; + + return 0 unless $opt{'resolve'}; + return 1 if $opt{'force'}; + + return $cached_answer{ $token } if exists $cached_answer{ $token }; + + print $msg, "\n"; + print "$action ALL records with the same defect? [N]: "; + my $a = <STDIN>; + return $cached_answer{ $token } = 1 if $a =~ /^(y|yes)$/i; + return $cached_answer{ $token } = 0; +} } + +{ my %cached_answer; +sub prompt_action { + my $actions = shift; + my $msg = shift; + my $token = shift || join ':', caller; + + return '' unless $opt{'resolve'}; + return '' if $opt{'force'}; + return $cached_answer{ $token } if exists $cached_answer{ $token }; + + print $msg, "\n"; + print join( ' or ', @$actions ) ." ALL records with the same defect? [do nothing]: "; + my $a = <STDIN>; + chomp $a; + return $cached_answer{ $token } = '' unless $a; + foreach ( grep rindex(lc $_, lc $a, 0) == 0, @$actions ) { + return $cached_answer{ $token } = lc substr $a, 0, 1; + } + return $cached_answer{ $token } = ''; +} } + +{ my %cached_answer; +sub prompt_integer { + my $action = shift; + my $msg = shift; + my $token = shift || join ':', caller; + + return 0 unless $opt{'resolve'}; + return 0 if $opt{'force'}; + + return $cached_answer{ $token } if exists $cached_answer{ $token }; + + print $msg, "\n"; + print "$action ALL records with the same defect? [0]: "; + my $a = <STDIN>; chomp $a; $a = int($a); + return $cached_answer{ $token } = $a; +} } + +1; diff --git a/rt/sbin/rt-validator.in b/rt/sbin/rt-validator.in new file mode 100644 index 0000000..ba2686e --- /dev/null +++ b/rt/sbin/rt-validator.in @@ -0,0 +1,1118 @@ +#!@PERL@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +use warnings; + +# fix lib paths, some may be relative +BEGIN { + require File::Spec; + my @libs = ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + my $bin_path; + + for my $lib (@libs) { + unless ( File::Spec->file_name_is_absolute($lib) ) { + unless ($bin_path) { + if ( File::Spec->file_name_is_absolute(__FILE__) ) { + $bin_path = ( File::Spec->splitpath(__FILE__) )[1]; + } + else { + require FindBin; + no warnings "once"; + $bin_path = $FindBin::Bin; + } + } + $lib = File::Spec->catfile( $bin_path, File::Spec->updir, $lib ); + } + unshift @INC, $lib; + } + +} + +use Getopt::Long; +my %opt = (); +GetOptions( + \%opt, + 'check|c', + 'resolve', + 'force', + 'verbose|v', +); + +usage() unless $opt{'check'}; +usage_warning() if $opt{'resolve'} && !$opt{'force'}; + +sub usage { + print STDERR <<END; +Usage: $0 options + +Options: + + $0 --check + $0 --check --verbose + $0 --check --verbose --resolve + $0 --check --verbose --resolve --force + +--check - is mandatory argument, you can use -c, as well. +--verbose - print additional info to STDOUT +--resolve - enable resolver that can delete or create some records +--force - resolve without asking questions + +Description: + +This script checks integrity of records in RT's DB. May delete some invalid +records or ressurect accidentally deleted. + +END + exit 1; +} + +sub usage_warning { + print <<END; +This utility can fix some issues with DB by creating or updating. In some +cases there is no enough data to resurect a missing record, but records which +refers to a missing can be deleted. It's up to you to decide what to do. + +In any case it's highly recommended to have a backup before resolving anything. + +Press enter to continue. +END + <>; +} + +use RT; +RT::LoadConfig(); +RT::Init(); + +my $dbh = $RT::Handle->dbh; +my $db_type = RT->Config->Get('DatabaseType'); + +my %TYPE = ( + 'Transactions.Field' => 'text', + 'Transactions.OldValue' => 'text', + 'Transactions.NewValue' => 'text', +); + +my @models = qw( + ACE + Attachment + Attribute + CachedGroupMember + CustomField + CustomFieldValue + GroupMember + Group + Link + ObjectCustomField + ObjectCustomFieldValue + Principal + Queue + ScripAction + ScripCondition + Scrip + Template + Ticket + Transaction + User +); + +my %redo_on; +$redo_on{'Delete'} = { + ACL => [], + + Attributes => [], + + Links => [], + + CustomFields => [], + CustomFieldValues => [], + ObjectCustomFields => [], + ObjectCustomFieldValues => [], + + Queues => [], + + Scrips => [], + ScripActions => [], + ScripConditions => [], + Templates => [], + + Tickets => [ 'Tickets -> other', 'Tickets <-> Role Groups' ], + Transactions => [ 'Attachments -> other' ], + + Principals => ['User <-> ACL equivalence group', 'GMs -> Groups, Members' ], + Users => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'Principals -> Users' ], + Groups => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'CGM vs. GM', 'Principals -> Groups' ], + + GroupMembers => [ 'CGM vs. GM' ], + CachedGroupMembers => [ 'CGM vs. GM' ], +}; +$redo_on{'Create'} = { + Principals => ['User <-> ACL equivalence group', 'GMs -> Groups, Members' ], + Groups => ['User <-> ACL equivalence group', 'GMs -> Groups, Members', 'CGM vs. GM' ], + GroupMembers => [ 'CGM vs. GM' ], + CachedGroupMembers => [ 'CGM vs. GM' ], +}; + +my %describe_cb; +%describe_cb = ( + Attachments => sub { + my $row = shift; + my $txn_id = $row->{transactionid}; + my $res = 'Attachment #'. $row->{id} .' -> Txn #'. $txn_id; + return $res .', '. describe( 'Transactions', $txn_id ); + }, + Transactions => sub { + my $row = shift; + return 'Transaction #'. $row->{id} .' -> object '. $row->{objecttype} .' #'. $row->{objectid}; + }, +); + +{ my %cache = (); +sub m2t($) { + my $model = shift; + return $cache{$model} if $cache{$model}; + my $class = "RT::$model"; + my $object = $class->new( $RT::SystemUser ); + return $cache{$model} = $object->Table; +} } + +my (@do_check, %redo_check); + +my @CHECKS; +foreach my $table ( qw(Users Groups) ) { + push @CHECKS, "$table -> Principals" => sub { + my $msg = "A record in $table refers not existing record in Principals." + ." The script can either create missing record in Principals" + ." or delete record in $table."; + my ($type) = ($table =~ /^(.*)s$/); + check_integrity( + $table, 'id' => 'Principals', 'id', + join_condition => 't.PrincipalType = ?', + bind_values => [ $type ], + action => sub { + my $id = shift; + return unless my $a = prompt_action( ['Delete', 'create'], $msg ); + + if ( $a eq 'd' ) { + delete_record( $table, $id ); + } + elsif ( $a eq 'c' ) { + my $principal_id = create_record( 'Principals', + id => $id, PrincipalType => $type, ObjectId => $id, Disabled => 0 + ); + } + else { + die "Unknown action '$a'"; + } + }, + ); + }; + + push @CHECKS, "Principals -> $table" => sub { + my $msg = "A record in Principals refers not existing record in $table." + ." In some cases it's possible to resurrect manually such records," + ." but this utility can only delete"; + + check_integrity( + 'Principals', 'id' => $table, 'id', + condition => 's.PrincipalType = ?', + bind_values => [ $table =~ /^(.*)s$/ ], + action => sub { + my $id = shift; + return unless prompt( 'Delete', $msg ); + + delete_record( 'Principals', $id ); + }, + ); + }; +} + +push @CHECKS, 'User <-> ACL equivalence group' => sub { + # from user to group + check_integrity( + 'Users', 'id' => 'Groups', 'Instance', + join_condition => 't.Domain = ? AND t.Type = ?', + bind_values => [ 'ACLEquivalence', 'UserEquiv' ], + action => sub { + my $id = shift; + return unless prompt( + 'Create', "Found an user that has no ACL equivalence group." + ); + + my $gid = create_record( 'Groups', + Domain => 'ACLEquivalence', Type => 'UserEquiv', Instance => $id, + ); + }, + ); + # from group to user + check_integrity( + 'Groups', 'Instance' => 'Users', 'id', + condition => 's.Domain = ? AND s.Type = ?', + bind_values => [ 'ACLEquivalence', 'UserEquiv' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found an user ACL equivalence group, but there is no user." + ); + + delete_record( 'Groups', $id ); + }, + ); + # one ACL equiv group for each user + check_uniqueness( + 'Groups', + columns => ['Instance'], + condition => '.Domain = ? AND .Type = ?', + bind_values => [ 'ACLEquivalence', 'UserEquiv' ], + ); +}; + +# check integrity of Queue role groups +push @CHECKS, 'Queues <-> Role Groups' => sub { + # XXX: we check only that there is at least one group for a queue + # from queue to group + check_integrity( + 'Queues', 'id' => 'Groups', 'Instance', + join_condition => 't.Domain = ?', + bind_values => [ 'RT::Queue-Role' ], + ); + # from group to queue + check_integrity( + 'Groups', 'Instance' => 'Queues', 'id', + condition => 's.Domain = ?', + bind_values => [ 'RT::Queue-Role' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found role group of not existant queue." + ); + + delete_record( 'Groups', $id ); + }, + ); +}; + +# check integrity of Ticket role groups +push @CHECKS, 'Tickets <-> Role Groups' => sub { + # XXX: we check only that there is at least one group for a queue + # from queue to group + check_integrity( + 'Tickets', 'id' => 'Groups', 'Instance', + join_condition => 't.Domain = ?', + bind_values => [ 'RT::Ticket-Role' ], + ); + # from group to ticket + check_integrity( + 'Groups', 'Instance' => 'Tickets', 'id', + condition => 's.Domain = ?', + bind_values => [ 'RT::Ticket-Role' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a role group of not existant ticket." + ); + + delete_record( 'Groups', $id ); + }, + ); +}; + +# additional CHECKS on groups +push @CHECKS, 'Role Groups (Instance, Type) uniqueness' => sub { + # Check that Domain, Instance and Type are unique + check_uniqueness( + 'Groups', + columns => ['Domain', 'Instance', 'Type'], + condition => '.Domain LIKE ?', + bind_values => [ '%-Role' ], + ); +}; + + +push @CHECKS, 'GMs -> Groups, Members' => sub { + my $msg = "A record in GroupMembers references an object that doesn't exist." + ." May be you deleted a group or principal directly from DB?" + ." Usually it's ok to delete such records."; + check_integrity( + 'GroupMembers', 'GroupId' => 'Groups', 'id', + action => sub { + my $id = shift; + return unless prompt( 'Delete', $msg ); + + delete_record( 'GroupMembers', $id ); + }, + ); + check_integrity( + 'GroupMembers', 'MemberId' => 'Principals', 'id', + action => sub { + my $id = shift; + return unless prompt( 'Delete', $msg ); + + delete_record( 'GroupMembers', $id ); + }, + ); +}; + +# CGM and GM +push @CHECKS, 'CGM vs. GM' => sub { + # all GM record should be duplicated in CGM + check_integrity( + GroupMembers => ['GroupId', 'MemberId'], + CachedGroupMembers => ['GroupId', 'MemberId'], + join_condition => 't.ImmediateParentId = t.GroupId AND t.Via = t.id', + action => sub { + my $id = shift; + return unless prompt( + 'Create', + "Found a record in GroupMembers that has no direct duplicate in CachedGroupMembers table." + ); + + my $gm = RT::GroupMember->new( $RT::SystemUser ); + $gm->Load( $id ); + die "Couldn't load GM record #$id" unless $gm->id; + my $cgm = create_record( 'CachedGroupMembers', + GroupId => $gm->GroupId, MemberId => $gm->MemberId, + ImmediateParentId => $gm->GroupId, Via => undef, + Disabled => 0, # XXX: we should check integrity of Disabled field + ); + update_records( "CachedGroupMembers", { id => $cgm }, { Via => $cgm } ); + }, + ); + # all first level CGM records should have a GM record + check_integrity( + CachedGroupMembers => ['GroupId', 'MemberId'], + GroupMembers => ['GroupId', 'MemberId'], + condition => 's.ImmediateParentId = s.GroupId AND s.Via = s.id AND s.GroupId != s.MemberId', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers for a (Group, Member) pair" + ." that doesn't exist in GroupMembers table." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + # each group should have a CGM record where MemberId == GroupId + check_integrity( + Groups => ['id', 'id'], + CachedGroupMembers => ['GroupId', 'MemberId'], + join_condition => 't.ImmediateParentId = t.GroupId AND t.Via = t.id', + action => sub { + my $id = shift; + return unless prompt( + 'Create', + "Found a record in Groups that has no direct" + ." duplicate in CachedGroupMembers table." + ); + + my $g = RT::Group->new( $RT::SystemUser ); + $g->Load( $id ); + die "Couldn't load group #$id" unless $g->id; + die "Loaded group by $id has id ". $g->id unless $g->id == $id; + my $cgm = create_record( 'CachedGroupMembers', + GroupId => $id, MemberId => $id, + ImmediateParentId => $id, Via => undef, + Disabled => $g->Disabled, + ); + update_records( "CachedGroupMembers", { id => $cgm }, { Via => $cgm } ); + }, + ); + + # and back, each record in CGM with MemberId == GroupId without exceptions + # should reference a group + check_integrity( + CachedGroupMembers => ['GroupId', 'MemberId'], + Groups => ['id', 'id'], + condition => "s.GroupId = s.MemberId", + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers for a group that doesn't exist." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + # Via + check_integrity( + CachedGroupMembers => 'Via', + CachedGroupMembers => 'id', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers with Via referencing not existing record." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + + # for every CGM where ImmediateParentId != GroupId there should be + # matching parent record (first level) + check_integrity( + CachedGroupMembers => ['ImmediateParentId', 'MemberId'], + CachedGroupMembers => ['GroupId', 'MemberId'], + join_condition => 't.Via = t.id', + condition => 's.ImmediateParentId != s.GroupId', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers that referencing not existant record in CachedGroupMembers table." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + + # for every CGM where ImmediateParentId != GroupId there should be + # matching "grand" parent record + check_integrity( + CachedGroupMembers => ['GroupId', 'ImmediateParentId', 'Via'], + CachedGroupMembers => ['GroupId', 'MemberId', 'id'], + condition => 's.ImmediateParentId != s.GroupId', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a record in CachedGroupMembers that referencing not existant record in CachedGroupMembers table." + ); + + delete_record( 'CachedGroupMembers', $id ); + }, + ); + + # CHECK recursive records: + # if we have CGM1 (G1,M1,V1,IP1) then for every GM2(G2, M2), where G2 == M1, + # we should have CGM3 where G3 = G1, M3 = M2, V3 = ID1, IP3 = M1 + { + my $query = <<END; +SELECT cgm1.GroupId, gm2.MemberId, cgm1.id AS Via, + cgm1.MemberId AS ImmediateParentId, cgm1.Disabled +FROM + CachedGroupMembers cgm1 + CROSS JOIN GroupMembers gm2 + LEFT JOIN CachedGroupMembers cgm3 ON ( + cgm3.GroupId = cgm1.GroupId + AND cgm3.MemberId = gm2.MemberId + AND cgm3.Via = cgm1.id + AND cgm3.ImmediateParentId = cgm1.MemberId ) +WHERE cgm1.GroupId != cgm1.MemberId +AND gm2.GroupId = cgm1.MemberId +AND cgm3.id IS NULL +END + + my $action = sub { + my %props = @_; + return unless prompt( + 'Create', + "Found records in CachedGroupMembers table without recursive duplicates." + ); + my $cgm = create_record( 'CachedGroupMembers', %props ); + }; + + my $sth = execute_query( $query ); + while ( my ($g, $m, $via, $ip, $dis) = $sth->fetchrow_array ) { + print STDERR "Principal #$m is member of #$ip when #$ip is member of #$g,"; + print STDERR " but there is no cached GM record that $m is member of #$g.\n"; + $action->( + GroupId => $g, MemberId => $m, Via => $via, + ImmediateParentId => $ip, Disabled => $dis, + ); + } + } +}; + +# Tickets +push @CHECKS, 'Tickets -> other' => sub { + check_integrity( + 'Tickets', 'EffectiveId' => 'Tickets', 'id', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', + "Found a ticket that's been merged into a ticket that don't exist anymore." + ); + + delete_record( 'Tickets', $id ); + }, + ); + check_integrity( + 'Tickets', 'Queue' => 'Queues', 'id', + ); + check_integrity( + 'Tickets', 'Owner' => 'Users', 'id', + ); + # XXX: check that owner is only member of owner role group +}; + + +push @CHECKS, 'Transactions -> other' => sub { + foreach my $model ( @models ) { + check_integrity( + 'Transactions', 'ObjectId' => m2t($model), 'id', + condition => 's.ObjectType = ?', + bind_values => [ "RT::$model" ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction without object." + ); + + delete_record( 'Transactions', $id ); + }, + ); + } + # type = CustomField + check_integrity( + 'Transactions', 'Field' => 'CustomFields', 'id', + condition => 's.Type = ?', + bind_values => [ 'CustomField' ], + ); + # type = Take, Untake, Force, Steal or Give + check_integrity( + 'Transactions', 'OldValue' => 'Users', 'id', + condition => 's.Type IN (?, ?, ?, ?, ?)', + bind_values => [ qw(Take Untake Force Steal Give) ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction regarding changes of Owner," + ." but User with id stored in OldValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + check_integrity( + 'Transactions', 'NewValue' => 'Users', 'id', + condition => 's.Type IN (?, ?, ?, ?, ?)', + bind_values => [ qw(Take Untake Force Steal Give) ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction regarding changes of Owner," + ." but User with id stored in NewValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + # type = DelWatcher + check_integrity( + 'Transactions', 'OldValue' => 'Principals', 'id', + condition => 's.Type = ?', + bind_values => [ 'DelWatcher' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction describing watchers change," + ." but User with id stored in OldValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + # type = AddWatcher + check_integrity( + 'Transactions', 'NewValue' => 'Principals', 'id', + condition => 's.Type = ?', + bind_values => [ 'AddWatcher' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction describing watchers change," + ." but User with id stored in NewValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + +# XXX: Links need more love, uri is stored instead of id +# # type = DeleteLink +# check_integrity( +# 'Transactions', 'OldValue' => 'Links', 'id', +# condition => 's.Type = ?', +# bind_values => [ 'DeleteLink' ], +# ); +# # type = AddLink +# check_integrity( +# 'Transactions', 'NewValue' => 'Links', 'id', +# condition => 's.Type = ?', +# bind_values => [ 'AddLink' ], +# ); + + # type = Set, Field = Queue + check_integrity( + 'Transactions', 'NewValue' => 'Queues', 'id', + condition => 's.Type = ? AND s.Field = ?', + bind_values => [ 'Set', 'Queue' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction describing queue change," + ." but Queue with id stored in NewValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + check_integrity( + 'Transactions', 'OldValue' => 'Queues', 'id', + condition => 's.Type = ? AND s.Field = ?', + bind_values => [ 'Set', 'Queue' ], + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found a transaction describing queue change," + ." but Queue with id stored in OldValue column doesn't exist anymore." + ); + + delete_record( 'Transactions', $id ); + }, + ); + # Reminders + check_integrity( + 'Transactions', 'NewValue' => 'Tickets', 'id', + join_condition => 't.Type = ?', + condition => 's.Type IN (?, ?, ?)', + bind_values => [ 'reminder', 'AddReminder', 'OpenReminder', 'ResolveReminder' ], + ); +}; + +# Attachments +push @CHECKS, 'Attachments -> other' => sub { + check_integrity( + Attachments => 'TransactionId', Transactions => 'id', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found an attachment without a transaction." + ); + delete_record( 'Attachments', $id ); + }, + ); + check_integrity( + Attachments => 'Parent', Attachments => 'id', + action => sub { + my $id = shift; + return unless prompt( + 'Delete', "Found an sub-attachment without its parent attachment." + ); + delete_record( 'Attachments', $id ); + }, + ); + check_integrity( + Attachments => 'Parent', + Attachments => 'id', + join_condition => 's.TransactionId = t.TransactionId', + ); +}; + +push @CHECKS, 'CustomFields and friends' => sub { + #XXX: ObjectCustomFields needs more love + check_integrity( + 'CustomFieldValues', 'CustomField' => 'CustomFields', 'id', + ); + check_integrity( + 'ObjectCustomFieldValues', 'CustomField' => 'CustomFields', 'id', + ); + foreach my $model ( @models ) { + check_integrity( + 'ObjectCustomFieldValues', 'ObjectId' => m2t($model), 'id', + condition => 's.ObjectType = ?', + bind_values => [ "RT::$model" ], + ); + } +}; + +push @CHECKS, Templates => sub { + check_integrity( + 'Templates', 'Queue' => 'Queues', 'id', + ); +}; + +push @CHECKS, Scrips => sub { + check_integrity( + 'Scrips', 'Queue' => 'Queues', 'id', + ); + check_integrity( + 'Scrips', 'ScripCondition' => 'ScripConditions', 'id', + ); + check_integrity( + 'Scrips', 'ScripAction' => 'ScripActions', 'id', + ); + check_integrity( + 'Scrips', 'Template' => 'Templates', 'id', + ); +}; + +push @CHECKS, Attributes => sub { + foreach my $model ( @models ) { + check_integrity( + 'Attributes', 'ObjectId' => m2t($model), 'id', + condition => 's.ObjectType = ?', + bind_values => [ "RT::$model" ], + ); + } +}; + +# Fix situations when Creator or LastUpdatedBy references ACL equivalence +# group of a user instead of user +push @CHECKS, 'FIX: LastUpdatedBy and Creator' => sub { + my %fix = (); + foreach my $model ( @models ) { + my $class = "RT::$model"; + my $object = $class->new( $RT::SystemUser ); + foreach my $column ( qw(LastUpdatedBy Creator) ) { + next unless $object->_Accessible( $column, 'auto' ); + + my $table = m2t($model); + my $query = <<END; +SELECT m.id, g.id, g.Instance +FROM + Groups g JOIN $table m ON g.id = m.$column +WHERE + g.Domain = ? + AND g.Type = ? +END + my $action = sub { + my ($gid, $uid) = @_; + return unless prompt( + 'Update', + "Looks like there were a bug in old versions of RT back in 2006\n" + ."that has been fixed. If other checks are ok then it's ok to update\n" + ."these records to point them to users instead of groups" + ); + $fix{ $table }{ $column }{ $gid } = $uid; + }; + + my $sth = execute_query( $query, 'ACLEquivalence', 'UserEquiv' ); + while ( my ($rid, $gid, $uid) = $sth->fetchrow_array ) { + print STDERR "Record #$rid in $table refers to ACL equivalence group #$gid of user #$uid"; + print STDERR " when must reference user.\n"; + $action->( $gid, $uid ); + if ( keys( %fix ) > 1000 ) { + $sth->finish; + last; + } + } + } + } + + if ( keys %fix ) { + foreach my $table ( keys %fix ) { + foreach my $column ( keys %{ $fix{ $table } } ) { + my $query = "UPDATE $table SET $column = ? WHERE $column = ?"; + while ( my ($gid, $uid) = each %{ $fix{ $table }{ $column } } ) { + update_records( $table, { $column => $gid }, { $column => $uid } ); + } + } + } + $redo_check{'FIX: LastUpdatedBy and Creator'} = 1; + } +}; + +push @CHECKS, 'LastUpdatedBy and Creator' => sub { + foreach my $model ( @models ) { + my $class = "RT::$model"; + my $object = $class->new( $RT::SystemUser ); + my $table = $object->Table; + foreach my $column ( qw(LastUpdatedBy Creator) ) { + next unless $object->_Accessible( $column, 'auto' ); + check_integrity( + $table, $column => 'Users', 'id', + action => sub { + my ($id, %prop) = @_; + return unless my $replace_with = prompt_integer( + 'Replace', + "Column $column should point to a user, but there is record #$id in table $table\n" + ."where it's not true. It's ok to replace these wrong references with id of any user.\n" + ."Note that id you enter is not checked. You can peak any user from your DB, but it's\n" + ."may be better to create a special user for this, for example 'user_that_has_been_deleted'\n" + ."or something like that.", + "$table.$column -> user #$prop{$column}" + ); + update_records( $table, { id => $id, $column => $prop{$column} }, { $column => $replace_with } ); + }, + ); + } + } +}; +my %CHECKS = @CHECKS; + +@do_check = do { my $i = 1; grep $i++%2, @CHECKS }; + +while ( my $check = shift @do_check ) { + $CHECKS{ $check }->(); + + foreach my $redo ( keys %redo_check ) { + die "check $redo doesn't exist" unless $CHECKS{ $redo }; + delete $redo_check{ $redo }; + next if grep $_ eq $redo, @do_check; # don't do twice + push @do_check, $redo; + } +} + +sub check_integrity { + my ($stable, @scols) = (shift, shift); + my ($ttable, @tcols) = (shift, shift); + my %args = @_; + + @scols = @{ $scols[0] } if ref $scols[0]; + @tcols = @{ $tcols[0] } if ref $tcols[0]; + + print "Checking integrity of $stable.{". join(', ', @scols) ."} => $ttable.{". join(', ', @tcols) ."}\n" + if $opt{'verbose'}; + + my $query = "SELECT s.id, ". join(', ', map "s.$_", @scols) + ." FROM $stable s LEFT JOIN $ttable t" + ." ON (". join( + ' AND ', map columns_eq_cond('s', $stable, $scols[$_] => 't', $ttable, $tcols[$_]), (0..(@scols-1)) + ) .")" + . ($args{'join_condition'}? " AND ( $args{'join_condition'} )": "") + ." WHERE t.id IS NULL" + ." AND ". join(' AND ', map "s.$_ IS NOT NULL", @scols); + + $query .= " AND ( $args{'condition'} )" if $args{'condition'}; + + my @binds = @{ $args{'bind_values'} || [] }; + if ( $tcols[0] eq 'id' && @tcols == 1 ) { + my $type = $TYPE{"$stable.$scols[0]"} || 'number'; + if ( $type eq 'number' ) { + $query .= " AND s.$scols[0] != ?" + } + elsif ( $type eq 'text' ) { + $query .= " AND s.$scols[0] NOT LIKE ?" + } + push @binds, 0; + } + + my $sth = execute_query( $query, @binds ); + while ( my ($sid, @set) = $sth->fetchrow_array ) { + print STDERR "Record #$sid in $stable references not existent record in $ttable\n"; + for ( my $i = 0; $i < @scols; $i++ ) { + print STDERR "\t$scols[$i] => '$set[$i]' => $tcols[$i]\n"; + } + print STDERR "\t". describe( $stable, $sid ) ."\n"; + $args{'action'}->( $sid, map { $scols[$_] => $set[$_] } (0 .. (@scols-1)) ) if $args{'action'}; + } +} + +sub describe { + my ($table, $id) = @_; + return '' unless my $cb = $describe_cb{ $table }; + + my $row = load_record( $table, $id ); + unless ( $row->{id} ) { + $table =~ s/s$//; + return "$table doesn't exist"; + } + return $cb->( $row ); +} + +sub columns_eq_cond { + my ($la, $lt, $lc, $ra, $rt, $rc) = @_; + my $ltype = $TYPE{"$lt.$lc"} || 'number'; + my $rtype = $TYPE{"$rt.$rc"} || 'number'; + return "$la.$lc = $ra.$rc" if $db_type ne 'Pg' || $ltype eq $rtype; + + if ( $rtype eq 'text' ) { + return "$ra.$rc LIKE CAST($la.$lc AS text)"; + } + elsif ( $ltype eq 'text' ) { + return "$la.$lc LIKE CAST($ra.$rc AS text)"; + } + else { die "don't know how to cast" } +} + +sub check_uniqueness { + my $on = shift; + my %args = @_; + + my @columns = @{ $args{'columns'} }; + + print "Checking uniqueness of ( ", join(', ', map "'$_'", @columns )," ) in table '$on'\n" + if $opt{'versbose'}; + + my ($scond, $tcond); + if ( $scond = $tcond = $args{'condition'} ) { + $scond =~ s/(\s|^)\./$1s./g; + $tcond =~ s/(\s|^)\./$1t./g; + } + + my $query = "SELECT s.id, t.id, ". join(', ', map "s.$_", @columns) + ." FROM $on s LEFT JOIN $on t " + ." ON s.id != t.id AND ". join(' AND ', map "s.$_ = t.$_", @columns) + . ($tcond? " AND ( $tcond )": "") + ." WHERE t.id IS NOT NULL " + ." AND ". join(' AND ', map "s.$_ IS NOT NULL", @columns); + $query .= " AND ( $scond )" if $scond; + + my $sth = execute_query( + $query, + $args{'bind_values'}? (@{ $args{'bind_values'} }, @{ $args{'bind_values'} }): () + ); + while ( my ($sid, $tid, @set) = $sth->fetchrow_array ) { + print STDERR "Record #$tid in $on has the same set of values as $sid\n"; + for ( my $i = 0; $i < @columns; $i++ ) { + print STDERR "\t$columns[$i] => '$set[$i]'\n"; + } + } +} + +sub load_record { + my ($table, $id) = @_; + my $sth = execute_query( "SELECT * FROM $table WHERE id = ?", $id ); + return $sth->fetchrow_hashref('NAME_lc'); +} + +sub delete_record { + my ($table, $id) = (@_); + print "Deleting record #$id in $table\n" if $opt{'verbose'}; + my $query = "DELETE FROM $table WHERE id = ?"; + $redo_check{ $_ } = 1 foreach @{ $redo_on{'Delete'}{ $table } || [] }; + return execute_query( $query, $id ); +} + +sub create_record { + print "Creating a record in $_[0]\n" if $opt{'verbose'}; + $redo_check{ $_ } = 1 foreach @{ $redo_on{'Create'}{ $_[0] } || [] }; + return $RT::Handle->Insert( @_ ); +} + +sub update_records { + my $table = shift; + my $where = shift; + my $what = shift; + + my (@where_cols, @where_binds); + while ( my ($k, $v) = each %$where ) { push @where_cols, $k; push @where_binds, $v; } + + my (@what_cols, @what_binds); + while ( my ($k, $v) = each %$what ) { push @what_cols, $k; push @what_binds, $v; } + + print "Updating record(s) in $table\n" if $opt{'verbose'}; + my $query = "UPDATE $table SET ". join(', ', map "$_ = ?", @what_cols) + ." WHERE ". join(' AND ', map "$_ = ?", @where_cols); + $redo_check{ $_ } = 1 foreach @{ $redo_on{'Update'}{ $table } || [] }; + return execute_query( $query, @what_binds, @where_binds ); +} + +sub execute_query { + my ($query, @binds) = @_; + + print "Executing query: $query\n\n" if $opt{'verbose'}; + + my $sth = $dbh->prepare( $query ) or die "couldn't prepare $query\n\tError: ". $dbh->errstr; + $sth->execute( @binds ) or die "couldn't execute $query\n\tError: ". $sth->errstr; + return $sth; +} + +{ my %cached_answer; +sub prompt { + my $action = shift; + my $msg = shift; + my $token = shift || join ':', caller; + + return 0 unless $opt{'resolve'}; + return 1 if $opt{'force'}; + + return $cached_answer{ $token } if exists $cached_answer{ $token }; + + print $msg, "\n"; + print "$action ALL records with the same defect? [N]: "; + my $a = <STDIN>; + return $cached_answer{ $token } = 1 if $a =~ /^(y|yes)$/i; + return $cached_answer{ $token } = 0; +} } + +{ my %cached_answer; +sub prompt_action { + my $actions = shift; + my $msg = shift; + my $token = shift || join ':', caller; + + return '' unless $opt{'resolve'}; + return '' if $opt{'force'}; + return $cached_answer{ $token } if exists $cached_answer{ $token }; + + print $msg, "\n"; + print join( ' or ', @$actions ) ." ALL records with the same defect? [do nothing]: "; + my $a = <STDIN>; + chomp $a; + return $cached_answer{ $token } = '' unless $a; + foreach ( grep rindex(lc $_, lc $a, 0) == 0, @$actions ) { + return $cached_answer{ $token } = lc substr $a, 0, 1; + } + return $cached_answer{ $token } = ''; +} } + +{ my %cached_answer; +sub prompt_integer { + my $action = shift; + my $msg = shift; + my $token = shift || join ':', caller; + + return 0 unless $opt{'resolve'}; + return 0 if $opt{'force'}; + + return $cached_answer{ $token } if exists $cached_answer{ $token }; + + print $msg, "\n"; + print "$action ALL records with the same defect? [0]: "; + my $a = <STDIN>; chomp $a; $a = int($a); + return $cached_answer{ $token } = $a; +} } + +1; diff --git a/rt/sbin/tweak-template-locstring b/rt/sbin/tweak-template-locstring new file mode 100644 index 0000000..b63a5bd --- /dev/null +++ b/rt/sbin/tweak-template-locstring @@ -0,0 +1,55 @@ +#!/usr/bin/perl -w +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC +# <jesse@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} +use strict; +# run this script with: +# perl -0pi sbin/tweak-template-locstring `ack -f share/html -G 'html$'` +s!\<\&\|\/l([^&]*)\&\>[\n\s]+(.*?)[\n\s]*\<\/\&\>!;my ($arg, $x) = ($1, $2); $x =~ s/\s*\n\s*/ /g;"<&|/l$arg&>$x</&>"!smge; + + +1; |