App-SD-0.75/0000755000175000017500000000000011604745260011500 5ustar spangspangApp-SD-0.75/MANIFEST0000644000175000017500000001251111604744567012642 0ustar spangspangbin/darcs-sd bin/git-sd bin/sd Changes contrib/git-post-commit-close-ticket contrib/sdticket.vim doc/testing doc/write_a_connector etc/sd.bash inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/ExtraTests.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Scripts.pm inc/Module/Install/Share.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/App/SD.pm lib/App/SD/CLI.pm lib/App/SD/CLI/Command.pm lib/App/SD/CLI/Command/Attachment/Content.pm lib/App/SD/CLI/Command/Attachment/Create.pm lib/App/SD/CLI/Command/Browser.pm lib/App/SD/CLI/Command/Clone.pm lib/App/SD/CLI/Command/Help.pm lib/App/SD/CLI/Command/Help/About.pm lib/App/SD/CLI/Command/Help/Aliases.pm lib/App/SD/CLI/Command/Help/Attachments.pm lib/App/SD/CLI/Command/Help/Authors.pm lib/App/SD/CLI/Command/Help/Commands.pm lib/App/SD/CLI/Command/Help/Comments.pm lib/App/SD/CLI/Command/Help/Config.pm lib/App/SD/CLI/Command/Help/Copying.pm lib/App/SD/CLI/Command/Help/Environment.pm lib/App/SD/CLI/Command/Help/History.pm lib/App/SD/CLI/Command/Help/Intro.pm lib/App/SD/CLI/Command/Help/Search.pm lib/App/SD/CLI/Command/Help/Settings.pm lib/App/SD/CLI/Command/Help/Sync.pm lib/App/SD/CLI/Command/Help/ticket_summary_format.pm lib/App/SD/CLI/Command/Help/Tickets.pm lib/App/SD/CLI/Command/Init.pm lib/App/SD/CLI/Command/Log.pm lib/App/SD/CLI/Command/Publish.pm lib/App/SD/CLI/Command/Server.pm lib/App/SD/CLI/Command/Shell.pm lib/App/SD/CLI/Command/Ticket/Attachment/Create.pm lib/App/SD/CLI/Command/Ticket/Attachment/Search.pm lib/App/SD/CLI/Command/Ticket/Basics.pm lib/App/SD/CLI/Command/Ticket/Comment.pm lib/App/SD/CLI/Command/Ticket/Comment/Create.pm lib/App/SD/CLI/Command/Ticket/Comment/Update.pm lib/App/SD/CLI/Command/Ticket/Comments.pm lib/App/SD/CLI/Command/Ticket/Create.pm lib/App/SD/CLI/Command/Ticket/Details.pm lib/App/SD/CLI/Command/Ticket/Review.pm lib/App/SD/CLI/Command/Ticket/Search.pm lib/App/SD/CLI/Command/Ticket/Show.pm lib/App/SD/CLI/Command/Ticket/Update.pm lib/App/SD/CLI/Command/Version.pm lib/App/SD/CLI/Dispatcher.pm lib/App/SD/CLI/Model/Attachment.pm lib/App/SD/CLI/Model/Ticket.pm lib/App/SD/CLI/Model/TicketComment.pm lib/App/SD/CLI/NewReplicaCommand.pm lib/App/SD/Collection/Attachment.pm lib/App/SD/Collection/Comment.pm lib/App/SD/Collection/Ticket.pm lib/App/SD/Config.pm lib/App/SD/ForeignReplica.pm lib/App/SD/ForeignReplica/PullEncoder.pm lib/App/SD/ForeignReplica/PushEncoder.pm lib/App/SD/Model/Attachment.pm lib/App/SD/Model/Comment.pm lib/App/SD/Model/Ticket.pm lib/App/SD/Record.pm lib/App/SD/Replica/debbugs.pm lib/App/SD/Replica/debbugs/PullEncoder.pm lib/App/SD/Replica/debbugs/PushEncoder.pm lib/App/SD/Replica/gcode.pm lib/App/SD/Replica/gcode/PullEncoder.pm lib/App/SD/Replica/gcode/PushEncoder.pm lib/App/SD/Replica/github.pm lib/App/SD/Replica/github/PullEncoder.pm lib/App/SD/Replica/github/PushEncoder.pm lib/App/SD/Replica/hm.pm lib/App/SD/Replica/hm/PullEncoder.pm lib/App/SD/Replica/hm/PushEncoder.pm lib/App/SD/Replica/lighthouse.pm lib/App/SD/Replica/lighthouse/PullEncoder.pm lib/App/SD/Replica/lighthouse/PushEncoder.pm lib/App/SD/Replica/redmine.pm lib/App/SD/Replica/redmine/PullEncoder.pm lib/App/SD/Replica/redmine/PushEncoder.pm lib/App/SD/Replica/rt.pm lib/App/SD/Replica/rt/PullEncoder.pm lib/App/SD/Replica/rt/PushEncoder.pm lib/App/SD/Replica/trac.pm lib/App/SD/Replica/trac/PullEncoder.pm lib/App/SD/Replica/trac/PushEncoder.pm lib/App/SD/Server.pm lib/App/SD/Server/Dispatcher.pm lib/App/SD/Server/View.pm lib/App/SD/Test.pm lib/App/SD/Util.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README share/web/static/css/main.css share/web/static/images/gradient.png share/web/static/images/sd.png t/01-create.t t/02-create-with-editor.t t/03-update-ticket-with-editor.t t/04-update-ticket-comment-with-editor.t t/06-ticket-show.t t/07-sort-group.t t/attachment-content.t t/big-hm-rt.t t/config t/data/bplogo.gif t/data/sd-ticket-create-verbose.tmpl t/data/sd-ticket-create.tmpl t/data/sd-ticket-update-all-props.tmpl t/data/sd-ticket-update-verbose-all-props.tmpl t/data/sd-ticket-update-verbose.tmpl t/data/sd-ticket-update.tmpl t/db.sqlite t/help.t t/no-email.t t/resolutions/db.sqlite t/scripts/ticket-comment-update-editor.pl t/scripts/ticket-create-editor.pl t/scripts/ticket-update-editor.pl t/sd-attachments.t t/sd-comments.t t/sd-dispatcher.t t/sd-gcode/basic.t t/sd-github/basic.t t/sd-hm/attachments.t t/sd-hm/basics.t t/sd-hm/comments.t t/sd-hm/comments1.t t/sd-hm/group.t t/sd-hm/push-reporter-not-pro.t t/sd-hm/push-reporter-pro.t t/sd-hm/tag.t t/sd-hm/update.t t/sd-lighthouse/basic.t t/sd-lighthouse/real-push.t t/sd-log.t t/sd-redmine/basic.t t/sd-redmine/clone.t t/sd-redmine/net_redmine_test.pl t/sd-redmine/README t/sd-rt/basic.t t/sd-rt/bogus-rt-data.t t/sd-rt/pull-owner.t t/sd-rt/pull-watchers.t t/sd-rt/race-condition.t t/sd-rt/rt-auto-open-conflict.t t/sd-rt/sd-rt-hm-single.t t/sd-rt/sd-rt-hm.t t/sd-rt/sd-rt-n-foreign-sync.t t/sd-rt/sd-rt-permission.t t/sd-trac/basic.t t/sd-trac/push-comment.t t/sd-trac/push-new-ticket-to-trac-then-pull.t t/sd-trac/setup_trac.pl t/sd-usage.t t/sd-validation.t t/server.t tools/dump_sd_help.pl tools/shipwright-package tools/shipwright-package-minimal xt/release/00-dependencies.t xt/release/99-pod-coverage.t xt/release/99-pod.t App-SD-0.75/tools/0000755000175000017500000000000011604745260012640 5ustar spangspangApp-SD-0.75/tools/dump_sd_help.pl0000755000175000017500000000355611604653213015650 0ustar spangspang#!/usr/bin/perl # Process sd help output to put on the website (markdown) use strict; use warnings; open GETHELP, 'sd help |' ; my @cmds; # grab what helps exist from the help index while () { next if !m/sd help /; (undef, undef, my $cmd, undef, my $desc) = split ' ', $_, 5; # push @cmds, [$cmd, $desc]; push @cmds, $cmd; } close GETHELP; # @cmds = ('environment'); # debug print qq{[[!meta title="Using SD"]]\n}; for (@cmds) { open my $cmd, "sd help $_ |"; my $text = slurp($cmd); # now we can do the real processing print process_help($text); } sub process_help { my ( $text ) = shift; # escape markdown metacharacters $text =~ s/_/\\_/g; # linkify http links, adapted from MRE 74 $text =~ s{ \b # Capture the URL to $1 ( # hostname http:// (?!example) [-a-z0-9]+(\.[-a-z0-9]+)*\.(com|org|us) \b ( / [-a-z0-9_:\@&?=?=+,.!/~*`%\$]* # optional path )? ) }{[$1]($1)}gix; # strip off extraneous leading newlines and convert the header into a # headline $text =~ s/^\n+sd \d\.\d\d - (.*)\n-+\n+/\n$1\n==========\n\n/; # strip off any lines that read 'see 'sd help $cmd'' which isn't # really appropriate for this as all the helpfiles are being displayed # in one place #$text =~ s/^.*(?=(?:For more informatio on [\w ]+)? see 'sd help).*$//mgs; # put codeblock markers around code blocks $text =~ s/((?:^ \S.*\n)+)/> $1/mg; # put code annotation markup around code annotations (lines indented # by 6 spaces in the raw help (this markup doesn't exist yet in the CSS) $text =~ s/((?:^ \S.*\n)+)/

$1<\/p>\n/mg; return $text; } # process_help_file sub slurp { my $fh = shift; local( $/ ) ; my $text = <$fh>; return $text; } App-SD-0.75/tools/shipwright-package0000644000175000017500000000515311552666431016354 0ustar spangspangexport TODAY=`date +%Y-%m-%d` export REPO=${HOME}/shipwright-sd-${TODAY}.git/ #export REPO=/tmp/shipwright-sd-${TODAY}.git/ export SHIPWRIGHT_REPOSITORY="git:file://$REPO" export MIN_PERL=5.008006 export SKIP="--skip=Pod::Simple,Module::Signature,Test::Pod,Test::Most,Quantum::SuperPositions,Test::Pod::Coverage,Test::Distribution,Pod::Readme,Archive::Tar,HTML::Lint,Prophet,Encode,Date::Calc,Test::Cukes,Quantum::Superpositions,Test::Memory::Cycle,Text::Greeking,Test::HTTP::Server::Simple,Test::WWW::Mechanize,Module::Build,Test::Warn,Test::MockTime,Test::MockModule,Test::MockObject,Test::Warn,HTTP::Cookies,HTTP::Request::Common,JSON::DWIW" export IMPORT="shipwright import --min-perl-version=$MIN_PERL $SKIP --log-file - --log-level debug" rm -rf $REPO shipwright create # Optional deps we still want $IMPORT \ cpan:Scalar::Util \ cpan:Template::Declare \ cpan:HTTP::Server::Simple \ cpan:File::ShareDir \ cpan:DBI \ cpan:DBD::SQLite \ cpan:Term::ReadLine::Perl \ cpan:JSON::XS \ cpan:Net::Bonjour \ cpan:Term::ReadKey \ cpan:Config::GitLike \ cpan:XSLoader \ git:http://github.com/bestpractical/prophet.git \ cpan:RT::Client::REST \ cpan:Email::Address \ cpan:Net::GitHub \ cpan:Net::Jifty \ cpan:Net::Trac \ cpan:Net::Google::Code \ git:http://github.com/bestpractical/sd.git cd /tmp #shipwright update cpan-Module-Build --add-deps cpan-Pod-Simple #shipwright update cpan-IO-Compress-Base --add-deps cpan-Scalar-List-Utils shipwright update cpan-Mouse --add-deps cpan-XSLoader shipwright update prophet.git --add-deps cpan-Term-ReadLine-Perl,cpan-TermReadKey,cpan-DBD-SQLite,cpan-File-ShareDir,cpan-HTTP-Server-Simple,cpan-JSON-XS,cpan-Config::GitLike shipwright update sd.git --add-deps prophet.git,cpan-Net-Bonjour,cpan-Email-Address,cpan-Net-Trac,cpan-RT-Client-REST,cpan-Net-Google-Code shipwright maintain --update-order cd /tmp git clone file://${REPO} hack-$$ cd /tmp/hack-$$/sources/cpan-Lingua-EN-Inflect/vendor git mv Build.pl Build.PL cd /tmp/hack-$$/scripts/cpan-DateTime-Format-Natural perl -pi -e 's/Build test/Build/g' build git config push.default matching git commit -m 'Made DTFN not run its tests which add a slew of deps' build cd /tmp/hack-$$/scripts/cpan-Net-DNS perl -pi -e 's/make:/make: COMMAND_MODE=unix2003/' build git commit -m 'hack COMMAND_MODE to make Net-DNS happy on mac' build git push cd /tmp/ rm -rf hack-$$ git clone file://$REPO /tmp/sdex-$$ cd /tmp/sdex-$$ rm -rf .git echo "# one argument per line --skip-man-pages --skip-test --install-base=~/sd " > __default_builder_options ./bin/shipwright-utility --generate-tar-file /tmp/sd-image-${TODAY}.bin rm -rf /tmp/sdex-$$ App-SD-0.75/tools/shipwright-package-minimal0000644000175000017500000000412211552666431017773 0ustar spangspangexport TODAY=`date +%Y-%m-%d` export REPO=${HOME}/shipwright-sd-min-${TODAY} export GIT_PATH="git:file://$REPO" export MIN_PERL=5.008006 export SKIP="--skip=Pod::Simple,Module::Signature,Test::Pod,Test::Pod::Coverage,Test::Distribution,Pod::Readme,Archive::Tar,HTML::Lint,Encode,Date::Calc,Test::Cukes,Quantum::Superpositions,Test::Memory::Cycle,Text::Greeking,Test::HTTP::Server::Simple,Test::WWW::Mechanize,Module::Build,Test::Warn,Test::MockTime,Test::MockModule,Test::MockObject,Test::Warn,Compress::Raw::Bzip2,Digest::SHA1,Compress::Raw::Zlib,Test::Script::Run,Test::Exception,Test::Simple,Test::More,Compress::Zlib,Digest::SHA" export IMPORT="shipwright import --min-perl-version=$MIN_PERL $SKIP -r $GIT_PATH --log-file - --log-level debug --skip-all-recommends" rm -rf $REPO mkdir $REPO shipwright create -r $GIT_PATH # Optional deps we still want $IMPORT \ cpan:Digest::SHA::PurePerl \ cpan:App::SD cd /tmp shipwright maintain -r $GIT_PATH --update-order cd /tmp git clone file://${REPO} hack-$$ cd /tmp/hack-$$/sources/cpan-Lingua-EN-Inflect/vendor git mv Build.pl Build.PL cd /tmp/hack-$$/scripts/cpan-DateTime-Format-Natural perl -pi -e 's/Build test/Build/g' build cd /tmp/hack-$$/scripts/cpan-Net-DNS perl -pi -e 's/make:/make: COMMAND_MODE=unix2003/' build git commit -m 'hack COMMAND_MODE to make Net-DNS happy on mac' build cd /tmp/hack-$$/scripts/cpan-Params-Util perl -pi -e 's/Makefile.PL/Makefile.PL -pm/g' build cd /tmp/hack-$$/scripts/cpan-Params-Validate perl -pi -e 's/Build.PL/Build.PL --pp/g' build cd /tmp/hack-$$/scripts/cpan-DateTime perl -pi -e 's/Makefile.PL/Makefile.PL --pm/g' build cd /tmp/hack-$$/scripts/cpan-List-MoreUtils perl -pi -e 's/Makefile.PL/Makefile.PL -pm/g' build git config push.default matching git commit -m 'Made DTFN not run its tests which add a slew of deps' -a git push cd /tmp/ rm -rf hack-$$ git clone file://$REPO /tmp/sdex-$$ cd /tmp/sdex-$$ rm -rf .git echo "# one argument per line --skip-man-pages --skip-test --install-base=~/sd " > __default_builder_options ./bin/shipwright-utility --generate-tar-file /tmp/sd-image-${TODAY}.bin rm -rf /tmp/sdex-$$ App-SD-0.75/etc/0000755000175000017500000000000011604745260012253 5ustar spangspangApp-SD-0.75/etc/sd.bash0000644000175000017500000000023311552666435013526 0ustar spangspang# add this to your bash_completion.d directory function _prophet_() { COMPREPLY=($($1 _gencomp ${COMP_WORDS[COMP_CWORD]})) } complete -F _prophet_ sd App-SD-0.75/xt/0000755000175000017500000000000011604745260012133 5ustar spangspangApp-SD-0.75/xt/release/0000755000175000017500000000000011604745260013553 5ustar spangspangApp-SD-0.75/xt/release/99-pod.t0000644000175000017500000000020211552666435014763 0ustar spangspanguse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); App-SD-0.75/xt/release/99-pod-coverage.t0000644000175000017500000000120011552666435016553 0ustar spangspanguse Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; plan skip_all => "Coverage tests only run for authors" unless ( -d 'inc/.author' ); plan skip_all => "We know our coverage is bad :("; all_pod_coverage_ok(); # Workaround for dumb bug (fixed in 5.8.7) where Test::Builder thinks that # certain "die"s that happen inside evals are not actually inside evals, # because caller() is broken if you turn on $^P like Module::Refresh does # # (I mean, if we've gotten to this line, then clearly the test didn't die, no?) Test::Builder->new->{Test_Died} = 0; App-SD-0.75/xt/release/00-dependencies.t0000644000175000017500000000416311552666435016617 0ustar spangspang#!/usr/bin/env perl use warnings; use strict; =head1 DESCRIPTION Makes sure that all of the modules that are 'use'd are listed in the Makefile.PL as dependencies. =cut use Test::More; use File::Find; eval 'use Module::CoreList'; if ($@) { plan skip_all => 'Module::CoreList not installed' } elsif ( ! -e 'inc/.author' ) { plan skip_all => 'no inc/.author, and it is on purpose ;)' } plan 'no_plan'; my %used; find( \&wanted, qw/ lib bin t / ); sub wanted { return unless -f $_; return if $File::Find::dir =~ m!/.svn($|/)!; return if $File::Find::name =~ /~$/; return if $File::Find::name =~ /\.(pod|html)$/; # read in the file from disk my $filename = $_; local $/; open( FILE, $filename ) or return; my $data = ; close(FILE); # strip pod, in a really idiotic way. Good enough though $data =~ s/^=head.+?(^=cut|\Z)//gms; # look for use and use base statements $used{$1}{$File::Find::name}++ while $data =~ /^\s*use\s+([\w:]+)/gm; while ( $data =~ m|^\s*use base qw.([\w\s:]+)|gm ) { $used{$_}{$File::Find::name}++ for split ' ', $1; } } my %required; { local $/; ok( open( MAKEFILE, "Makefile.PL" ), "Opened Makefile" ); my $data = ; close(FILE); while ( $data =~ /^\s*?(?:requires|recommends)?.*?([\w:]+)'(?:\s*=>\s*['"]?([\d\.]+)['"]?)?.*?(?:#(.*))?$/gm ) { $required{$1} = $2; if ( defined $3 and length $3 ) { $required{$_} = undef for split ' ', $3; } } } for ( sort keys %used ) { my $first_in = Module::CoreList->first_release($_); next if defined $first_in and $first_in <= 5.00803; next if /^(SVB|SDTestsEditor|Prophet|App::SD|inc|t)(::|$)/; #warn $_; ok( exists $required{$_}, "$_ in Makefile.PL" ) or diag( "used in ", join ", ", sort keys %{ $used{$_} } ); delete $used{$_}; delete $required{$_}; } for ( sort keys %required ) { my $first_in = Module::CoreList->first_release( $_, $required{$_} ); fail("Required module $_ (v. $required{$_}) is in core since $first_in") if defined $first_in and $first_in <= 5.008003; } 1; App-SD-0.75/META.yml0000644000175000017500000000130711407460725012753 0ustar spangspang--- author: - '2008-2009 Best Practical Solutions, LLC' build_requires: ExtUtils::MakeMaker: 6.42 Test::Script::Run: 0.02 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.91' license: MIT meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: App-SD no_index: directory: - inc - share - t - xt recommends: Email::Address: 0 Net::GitHub: 0.18 Net::Google::Code: 0.14 Net::Jifty: 0 Net::Trac: 0 RT::Client::REST: 0 requires: DateTime: 0 DateTime::Format::Natural: 0 HTML::Tree: 0 HTML::TreeBuilder: 0 Prophet: 0 Time::Progress: 0 URI::file: 0 version: 0.74 App-SD-0.75/doc/0000755000175000017500000000000011604745260012245 5ustar spangspangApp-SD-0.75/doc/write_a_connector0000644000175000017500000000472211552666431015705 0ustar spangspangwe need connectors to connect outside bug trackers and SD. currently we have a few of them in lib/App/SD/Replica/ If you want to write another one, here is a simple introduction to the skeleton of what a connector looks like. You can also refer to those existed ones to get the example code. Let's call the outside bug tracker( also named "Foreign Replica" in SD ) Foo here, then the module is named App::SD::Replica::foo. Assuming the client library of Foo is Net::Foo, by which we can communicate with Foo. App::SD::Replica::foo: some important attributes/methods: scheme: the scheme to indicate the url is a foo replica normally, it's the same as the package name's last part: 'foo' pull_encoder: class name for pulling(importing data from outside) normally, it's App::SD::Replica::foo::PullEncoder push_encoder: class name for pushing(exporting data to outside) normally, it's App::SD::Replica::foo::PushEncoder query: query string parsed from url foo: instance of Net::Foo if you want uuid(): uuid of the replica, may be calculated from the url database_settings(): you can customize database settings here get_txn_list_by_date($ticket): returns transactions(ordered from latest to earliest) of the $ticket. it's used to record transactions we pushed from SD. When creating an object of App::SD::Replica::foo, we need to parse the url( e.g. foo:/project/ticket/list/query, which is read from user's input ) and init things, e.g. init foo attribute with Net::Foo. We suggest use Any::Moose and do this job in BUILD method App::SD::Replica::foo::PullEncoder: some important attributes/methods: sync_source: the object of App::SD::Replica::foo ticket_id( $ticket ): returns the ticket's remote id find_matching_tickets( query => $query ): returns an arrayref of tickets we want to traverse find_matching_transactions( ticket => $id, starting_transaction => $num ) returns an arrayref of all transactions (as hashes) on ticket $id after transaction $num. translate_ticket_state( $ticket, $transactions ): returns a list with 2 elements, first is initial state, last is final state transcode_one_txn( $txn, $initial_state, $final_state ): returns an object of Prophet::ChangeSet App::SD::Replica::foo::PushEncoder: sync_source: the object of App::SD::Replica::foo integrate_change( $change, $changeset ): pushes to remote Foo App-SD-0.75/doc/testing0000644000175000017500000000050011552666431013644 0ustar spangspangTo run all tests including rt and hm: JIFTY_APP_ROOT=/Users/clkao/work/bps/BTDT RT_DBA_USER=root RT_DBA_PASSWORD= PERL5LIB=/Users/clkao/work/bps/rt-3.7/lib make test to collect coverage: JIFTY_APP_ROOT=/Users/clkao/work/bps/BTDT RT_DBA_USER=root RT_DBA_PASSWORD= PERL5LIB=/Users/clkao/work/bps/rt-3.7/lib cover -test App-SD-0.75/Makefile.PL0000644000175000017500000000341411604653213013450 0ustar spangspanguse inc::Module::Install; name('App-SD'); author('Jesse Vincent and Chia-Liang Kao'); #copyright('2008-2009 Best Practical Solutions, LLC'); license('MIT'); version_from('lib/App/SD.pm'); requires 'Prophet'; # URI Params::Validate Class::Accessor Template::Declare::Tags Test::HTTP::Server::Simple JSON Test::WWW::Mechanize Any::Moose requires('DateTime'); requires('Time::Progress'); # versions < 4.1 are buggy handling utf8 requires('HTML::TreeBuilder' => '4.1'); requires('DateTime::Format::Natural'); requires('HTML::Tree'); requires('URI::file'); requires('Try::Tiny' => '0.02'); build_requires('Test::Script::Run' => '0.02'); feature 'RT sync' => ( -default => 0, 'RT::Client::REST' => 0, # RT::Client::REST::Ticket ); recommends 'RT::Client::REST'; feature 'Hiveminder sync' => ( -default => 0, 'Net::Jifty' => 0.09, 'Email::Address' => 0, 'Email::MIME' => 0, 'Path::Class' => 0, ); recommends 'Net::Jifty'; recommends 'Email::Address'; feature 'Trac sync' => ( -default => 0, 'LWP::Simple' => 0, 'Net::Trac' => 0.16, ); recommends 'Net::Trac'; feature 'Google Code sync (experimental)' => ( -default => 0, 'Net::Google::Code' => 0.14, ); recommends 'Net::Google::Code' => 0.14; feature 'GitHub sync (experimental)' => ( -default => 0, 'Net::GitHub' => 0.28, 'Config::GitLike' => 1.03, ); recommends 'Net::GitHub' => 0.18; feature 'Redmine sync (experimental)' => ( -default => 0, 'Net::Redmine' => 0.08, ); feature 'Lighthouse sync' => ( -default => 0, 'Net::Lighthouse' => 0.01, ); install_script('bin/sd'); install_script('bin/git-sd'); install_script('bin/darcs-sd'); install_share('share'); # Include subdirectory tests too. tests("t/*.t t/*/*.t"); extra_tests; auto_install; &WriteAll; App-SD-0.75/Changes0000644000175000017500000000762711604731475013012 0ustar spangspang0.75 The "this is getting ridiculous" release. User-visible highlights (not all commits are listed here): * fix hiveminder logins when setting username/password via URL (spang) * bump dependencies to fix bitrot (spang, obra, franck) * foreign replicas now have better username/password prompting (spang) * clean up hiveminder sync messages (spang) * fix cloning from hiveminder (spang) * progress bar cleanups on clone/pull (spang) * publish --html works again (sunnavy, spang) * new server default port that clashes less with other HTTP servers (spang) * misc mac fixes (obra, sunnavy) * make -h more discoverable (spang) * new 'help commands' page (spang) * 'help browser' and 'help clone' now point to sync help (obra, spang) * mention --as and --local in clone usage messages (spang) * add some SD-specific bash completion rules (jibsheet) 0.74 User-visible highlights for this release (not all commits are listed here): * Make tests clean up after themselves - Alex Vandiver * friendlier error message if user tries to sync with RT without RT::Client::REST - Christine Spang * Check for http:// in RT URL regex since RT::Client::REST expects it - Christine Spang * Report back errors on login failure in RT sync - Christine Spang * Three minor tweaks for Moose compatibility - Christine Spang * Shipwright packaging - Jesse Vincent * UNIVERSAL::require is neither a dependency of prophet nor required - Jesse Vincent * Update SD to use the new database_bonjour_name API provided by prophet - Jesse Vincent * Make hyperlinks in SD relative - Jesse Vincent * RT servers can run on https:// servers - Kevin Falcone * redmine test: do require test inside BEGIN block - Sam Vilain * Redmine test improvements - franck cuny * if there is a trailing slash at the end of the URI, the github api will fail to fetch the data - franck cuny * fix: lighthouse->open_states_list auto deref - sunnavy * add query string support and increase performance for gcode sync - sunnavy Thanks to the following people who contributed to this release: Alex Vandiver, Christine Spang, Jesse Vincent, Kevin Falcone, Sam Vilain, franck cuny, and sunnavy. 0.73 * updates to the shipwright packager - Jesse Vincent * fix an uninitialized value warning in bin/sd - sunnavy * Document using x509 client certificates with trac. - Nelson Elhage * Document new alias behavior in 'help aliases' - Nelson Elhage * add feature lighthouse to Makefile.PL - sunnavy * fix quoted args in darcs-sd - Christine Spang * update lighthouse replica: use auth; versions and attachments can return arra y - sunnavy 0.72 * Initial cut of a lighthouse sync - attachment support for lighthouse, but push only has skeleton: waiting for their api updates - sunnavy * Add --version / -V - Christine Spang * Now we can push attachments to trac! And we _test_ them - Jesse Vincent * made "sd help attach" work - Jesse Vincent * Fix push of comments to trac - Jesse Vincent 0.71 * Fix a broken regexp in manifest.skip which stopped SD on CPAN from having a pretty webui - thanks to Nelson Elhage * Added documentation about proper clone command to use with a local sd server - Pedro Melo * GitHub UI improvements and related updates for prompt_for_login API change - Christine Spang * In the Redmine tests, we weren't doing all of our test skips in the BEGIN {} block. Marcus Ramberg caught this * All help references for summary format should be 'ticket.summary-format' - Christine Spang * bugfix: be able to delete props that aren't in common_ticket_props from the - Christine Spang editor - Christine Spang * Fix a help typo pointed out by Gerfried Fuchs - Christine Spang * Further fixes/clarifications for search help. - Christine Spang 0.70 - 2009-08-26 * Workaround for occasionally broken Ruby date formatting libraries in github replicas * Minor testing and formatting change 0.69_01 - 2009-08-21 * Initial release - dev release to do CPAN smoking before official release App-SD-0.75/lib/0000755000175000017500000000000011604745260012246 5ustar spangspangApp-SD-0.75/lib/App/0000755000175000017500000000000011604745260012766 5ustar spangspangApp-SD-0.75/lib/App/SD/0000755000175000017500000000000011604745260013274 5ustar spangspangApp-SD-0.75/lib/App/SD/ForeignReplica/0000755000175000017500000000000011604745260016165 5ustar spangspangApp-SD-0.75/lib/App/SD/ForeignReplica/PushEncoder.pm0000644000175000017500000000376511565067537020767 0ustar spangspangpackage App::SD::ForeignReplica::PushEncoder; use Any::Moose; use Params::Validate; sub integrate_change { my $self = shift; my ( $change, $changeset ) = validate_pos( @_, { isa => 'Prophet::Change' }, { isa => 'Prophet::ChangeSet' } ); my ($id, $record); # if the original_sequence_no of this changeset is <= # the last changeset our sync source for the original_sequence_no, we can skip it. # XXX TODO - this logic should be at the changeset level, not the cahnge level, as it applies to all # changes in the changeset my $before_integration = time(); eval { if ( $change->record_type eq 'ticket' and $change->change_type eq 'add_file' ) { $id = $self->integrate_ticket_create( $change, $changeset ); $self->sync_source->record_remote_id_for_pushed_record( uuid => $change->record_uuid, remote_id => $id); } elsif ( $change->record_type eq 'attachment' and $change->change_type eq 'add_file') { $id = $self->integrate_attachment( $change, $changeset ); } elsif ( $change->record_type eq 'comment' and $change->change_type eq 'add_file' ) { $id = $self->integrate_comment( $change, $changeset ); } elsif ( $change->record_type eq 'ticket' ) { $id = $self->integrate_ticket_update( $change, $changeset ); } else { $self->sync_source->log('I have no idea what I am doing for '.$change->record_uuid); return undef; } $self->sync_source->record_pushed_transactions( start_time => $before_integration, ticket => $id, changeset => $changeset); }; if (my $err = $@) { $self->sync_source->log("Push error: ".$err); } $self->after_integrate_change(); return $id; } sub after_integrate_change {} no Any::Moose; __PACKAGE__->meta->make_immutable; 1; App-SD-0.75/lib/App/SD/ForeignReplica/PullEncoder.pm0000644000175000017500000001163511565067537020757 0ustar spangspangpackage App::SD::ForeignReplica::PullEncoder; use Any::Moose; use App::SD::Util; use Params::Validate qw/validate/; with 'Prophet::CLI::ProgressBar'; sub run { my $self = shift; my %args = validate( @_, { after => 1}); $self->sync_source->log('Finding matching tickets'); my $tickets = $self->find_matching_tickets( query => $self->sync_source->query ); if ( @$tickets == 0 ) { $self->sync_source->log("No tickets found."); return; } my $counter = 0; $self->sync_source->log_debug("Discovering ticket history"); my ( $last_modified, $last_txn, @changesets ); my $progress = $self->progress_bar( max => $#$tickets, format => "Fetching ticket history %30b %p Est: %E\r", ); for my $ticket (@$tickets) { $counter++; my $changesets; $progress->(); $self->sync_source->log_debug( "Fetching $counter of " . scalar @$tickets . " tickets"); ( $last_modified, $changesets ) = $self->transcode_ticket( $ticket, $last_modified ); unshift @changesets, @$changesets; } my $sorted_changesets = [ sort { $a->original_sequence_no <=> $b->original_sequence_no } @changesets ]; return $sorted_changesets; } sub ticket_last_modified { undef} sub transcode_ticket { my $self = shift; my $ticket = shift; my $last_modified = shift; my @changesets; if ( my $ticket_last_modified = $self->ticket_last_modified($ticket) ) { $last_modified = $ticket_last_modified if ( !$last_modified || $ticket_last_modified > $last_modified ); } my $transactions = $self->find_matching_transactions( ticket => $ticket, starting_transaction => $self->sync_source->app_handle->handle->last_changeset_from_source( $self->sync_source->uuid_for_remote_id( $self->ticket_id($ticket) ) ) || 1 ); my $changesets; ( $last_modified, $changesets ) = $self->transcode_history( $ticket, $transactions, $last_modified ); return ( $last_modified, $changesets ); } sub transcode_history { my $self = shift; my $ticket = shift; my $transactions = shift; my $last_modified = shift; my $ticket_id = $self->ticket_id($ticket); my @changesets; # Walk transactions newest to oldest. my $txn_counter = 0; my ($initial_state, $final_state) = $self->translate_ticket_state($ticket, $transactions); for my $txn ( sort { $b->{'serial'} <=> $a->{'serial'} } @$transactions ) { $last_modified = $txn->{timestamp} if ( !$last_modified || ( $txn->{timestamp} > $last_modified ) ); $self->sync_source->log_debug( "$ticket_id Transcoding transaction " . ++$txn_counter . " of " . scalar @$transactions ); my $changeset = $self->transcode_one_txn( $txn, $initial_state, $final_state ); next unless $changeset && $changeset->has_changes; # the changesets are older than the ones that came before, so they go # first unshift @changesets, $changeset; } return ( $last_modified, \@changesets ); } sub translate_ticket_state { die 'translate_ticket_state must be implemented'; } sub warp_list_to_old_value { my $self = shift; my $current = shift; my $add = shift; my $del = shift; $_ = '' foreach grep !defined, $current, $add, $del; my @new = grep defined && length, split /\s*,\s*/, $current; my @old = grep defined && length && $_ ne $add, (@new, $del); return join( ", ", @old ); } =head2 _only_pull_tickets_modified_after If we've previously pulled from this sync source, this routine will return a datetime object. It's safe not to evaluate any ticket last modified before that datetime =cut sub _only_pull_tickets_modified_after { my $self = shift; # last modified date is in GMT and searches are in user-time XXX -check assumption # because of this, we really want to back that date down by one day to catch overlap # XXX TODO we are playing FAST AND LOOSE WITH DATE MATH # XXX TODO THIS WILL HURT US SOME DAY # At that time, Jesse will buy you a beer. my $last_pull = $self->sync_source->upstream_last_modified_date(); return undef unless $last_pull; my $before = App::SD::Util::string_to_datetime($last_pull); die "Failed to parse '" . $self->sync_source->upstream_last_modified_date() . "' as a timestamp" unless ($before); # 26 hours ago deals with most any possible timezone/dst edge case $before->subtract( hours => 26 ); return $before; } sub new_comment_creation_change { my $self = shift; return Prophet::Change->new( { record_type => 'comment', record_uuid => $self->sync_source->uuid_generator->create_str() , # comments are never edited, we can have a random uuid change_type => 'add_file' } ); } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/Config.pm0000644000175000017500000001460611552666431015052 0ustar spangspangpackage App::SD::Config; use Any::Moose; use File::Spec; extends 'Prophet::Config'; { ### XXX This code is for BACKCOMPAT ONLY! Eventually, we want to kill it ### completely. sub _old_app_config_file { my $self = shift; # The order of preference for (OLD!) config files is: # $ENV{SD_CONFIG} > fs_root/config > fs_root/prophetrc (for backcompat) # $HOME/.sdrc > $ENV{PROPHET_APP_CONFIG} > $HOME/.prophetrc # if we set PROPHET_APP_CONFIG here, it will mess up legit uses of the # new config file setup my $old_file = $self->_file_if_exists($ENV{'SD_CONFIG'}) || $self->_file_if_exists( File::Spec->catfile($self->app_handle->handle->fs_root => 'config')) || $self->_file_if_exists( File::Spec->catfile($self->app_handle->handle->fs_root => 'prophetrc')) || $self->_file_if_exists( File::Spec->catfile($ENV{'HOME'}.'/.sdrc')) || $ENV{'PROPHET_APP_CONFIG'} # don't overwrite with nothing || ''; # don't write undef return $self->_file_if_exists($old_file) || $self->_file_if_exists( File::Spec->catfile( $ENV{'HOME'} => '.prophetrc' )) || $self->_file_if_exists( File::Spec->catfile( $self->app_handle->handle->fs_root => 'config' )) || $self->_file_if_exists( File::Spec->catfile( $self->app_handle->handle->fs_root => 'prophetrc' )) || File::Spec->catfile( $self->app_handle->handle->fs_root => 'config' ); } override load => sub { my $self = shift; Prophet::CLI->end_pager(); # Do backcompat stuff. for my $file ( ($self->_old_app_config_file, $self->dir_file, $self->user_file, $self->global_file) ) { my $content = -f $file ? Prophet::Util->slurp($file) : '['; # config file is old # Also "converts" empty files but that's fine. If it ever # does happen, we get the positive benefit of writing the # config format to it. if ( $content !~ /\[/ ) { $self->convert_ancient_config_file($file); } } Prophet::CLI->start_pager(); # Do a regular load. $self->SUPER::load(@_); }; ### XXX BACKCOMPAT ONLY! We eventually want to kill this hash, modifier and ### the following methods. # None of these need to have values mucked with at all, just the keys # migrated from old to new. our %KEYS_CONVERSION_TABLE = ( 'email_address' => 'user.email-address', 'default_group_ticket_list' => 'ticket.default-group', 'default_sort_ticket_list' => 'ticket.default-sort', 'summary_format_ticket' => 'ticket.summary-format', 'default_summary_format' => 'record.summary-format', 'common_ticket_props' => 'ticket.common-props', 'disable_ticket_show_history_by_default' => 'ticket.no-implicit-history-display', ); sub convert_ancient_config_file { my $self = shift; my $file = shift; print "Detected old format config file $file. Converting to ". "new format... "; # read in and parse old config my $config = { _sources => {}, _aliases => {} }; $self->_load_old_config_from_file( $file, $config ); my $aliases = delete $config->{_aliases}; my $sources = delete $config->{_sources}; # new configuration will include a config format version # my @config_to_set = ( { key => 'core.config-format-version', value => $self->FORMAT_VERSION, } ); # convert its keys to new-style keys by comparing to a conversion # table for my $key ( keys %$config ) { die "Unknown key '$key' in old format config file '$file'." ." Remove it or ask\non irc.freenode.net #prophet if you" ." think this is a bug.\n" unless exists $KEYS_CONVERSION_TABLE{$key}; push @config_to_set, { key => $KEYS_CONVERSION_TABLE{$key}, value => $config->{$key}, }; } # convert its aliases for my $alias ( keys %$aliases ) { push @config_to_set, { key => "alias.'$alias'", value => $aliases->{$alias}, }; } # convert its sources for my $name ( keys %$sources ) { my ($url, $uuid) = split(/ \| /, $sources->{$name}, 2); push @config_to_set, { key => "replica.'$name'.url", value => $url, }, { key => "replica.'$name'.uuid", value => $uuid, }; } # move the old config file to a backup my $backup_file = $file; unless ( $self->_deprecated_repo_config_names->{$file} ) { $backup_file = "$file.bak"; rename $file, $backup_file; } # we want to write the new file to a supported filename if # it's from a deprecated config name (replica/prophetrc) $file = File::Spec->catfile( $self->app_handle->handle->fs_root, 'config' ) if $self->_deprecated_repo_config_names->{$file}; # write the new config file (with group_set) $self->group_set( $file, \@config_to_set, 1); # tell the user that we're done print "done.\nOld config can be found at $backup_file; " ,"new config is $file.\n\n"; } sub _deprecated_repo_config_names { my $self = shift; my %filenames = ( File::Spec->catfile( $self->app_handle->handle->fs_root => 'prophetrc' ) => 1 ); return wantarray ? %filenames : \%filenames; }; sub _load_old_config_from_file { my $self = shift; my $file = shift; my $config = shift || {}; for my $line (Prophet::Util->slurp($file) ) { $line =~ s/\#.*$//; # strip comments next unless ($line =~ /^(.*?)\s*=\s*(.*)$/); my $key = $1; my $val = $2; if ($key =~ m!alias\s+(.+)!) { $config->{_aliases}->{$1} = $val; } elsif ($key =~ m!source\s+(.+)!) { $config->{_sources}->{$1} = $val; } else { $config->{$key} = $val; } } $config->{_aliases} ||= {}; # default aliases is null. $config->{_sources} ||= {}; # default to no sources. } } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/Server/0000755000175000017500000000000011604745260014542 5ustar spangspangApp-SD-0.75/lib/App/SD/Server/Dispatcher.pm0000644000175000017500000001161411604653213017165 0ustar spangspangpackage App::SD::Server::Dispatcher; use Prophet::Server::Dispatcher -base; on qr'.' => sub { my $self = shift; my $result = $self->server->result->get('create-ticket'); if ( $result && $result->success ) { $self->server->_send_redirect( to => '/ticket/' . $result->record_uuid ); } else { next_rule; } }; on qr'.' => sub { my $self = shift; $self->server->page_nav->child( history => label => 'History', url => '/history'); my $tickets = $self->server->page_nav->child( tickets => label => 'Tickets', url => '/'); $tickets->child( go => label => '

Show ticket #
', escape_label => 0) unless($self->server->static); my $milestones = $tickets->child( milestones => label => 'Milestones', url => '/milestones'); my $items = $self->server->app_handle->setting( label => 'milestones' )->get(); foreach my $item (@$items) { my $m = $milestones->child( $item => label => $item, url => '/milestone/'.$item); #$m->child('all' => label => 'All', url => '/milestone/'.$item.'/all'); #$m->child('mine' => label => 'Mine', url => '/milestone/'.$item.'/mine'); #$m->child('closed' => label => 'Closed', url => '/milestone/'.$item.'/closed'); } $milestones->child( none => label => 'None', url => '/milestone/'); my $components = $tickets->child( components => label => 'Components', url => '/components'); my $component_list = $self->server->app_handle->setting( label => 'components' )->get(); foreach my $item (@$component_list) { my $c= $components->child( $item => label => $item, url => '/component/'.$item); #$c->child('all' => label => 'All', url => '/component/'.$item.'/all'); #$c->child('mine' => label => 'Mine', url => '/component/'.$item.'/mine'); #$c->child('closed' => label => 'Closed', url => '/component/'.$item.'/closed'); } $components->child('None' => label => 'None', url => '/component/'); $tickets->child( all => label => 'All' => url => '/tickets/all'); $self->server->page_nav->child( create => label => 'New ticket', url => '/ticket/new') unless($self->server->static); $self->server->page_nav->child( home => label => 'Home', url => '/'); next_rule; }; under { method => 'POST' } => sub { # reject edits from non-localhost on qr'.' => sub { my $self = shift; if ( $self->server->cgi->remote_host() ne '127.0.0.1' ) { $self->server->_send_401; } else { next_rule; } }; on qr'^/ticket/([\w\d-]+)/edit$' => sub { shift->server->_send_redirect( to => '/ticket/' . $1 ); }; on qr'^/(?!records)$' => sub { shift->server->_send_redirect( to => $1 ); }; }; under { method => 'GET' } => sub { on qr'^/static/sd/(.*)$' => sub { shift->server->send_static_file($1)}; on qr'^/(milestone|component|status)/([\w\d-]*)$' => sub { my $name = $1; my $type = $2; shift->show_template( $name => $type ); }; on qr'^/history/?(\d*)/?$' => sub {my $since = $1; shift->show_template('history', $since)}; on qr'^/tickets/all$' => sub {shift->show_template('all_tickets')}; under qr'^/ticket/' => sub { on '' => sub { my $self = shift; if ( my $id = $self->server->cgi->param('id') ) { $self->server->_send_redirect( to => "/ticket/$id/view" ); } else { next_rule; } }; on 'new' => sub { shift->show_template('new_ticket') }; on qr'^([\w\d-]+)/?' => sub { my $self = shift; my $id = $1; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->server->app_handle, handle => $self->server->app_handle->handle ); $ticket->load(($id =~ /^\d+$/ ? 'luid' : 'uuid') =>$id); if (!$ticket->luid) { $self->server->_send_404(); #redirect( to => "/error/ticket_does_not_exist"); } else { next_rule; } }; on qr'^([\w\d-]+)/?$' => sub { shift->server->_send_redirect( to => "/ticket/$1/view" ) }; on qr'^([\w\d-]+)/edit$' => sub { shift->show_template( 'edit_ticket', $1 ) }; on qr'^([\w\d-]+)/history$' => sub { shift->show_template( 'show_ticket_history', $1 ) }; on qr'^([\w\d-]+)/view$' => sub { shift->show_template( 'show_ticket', $1 ) }; }; }; redispatch_to 'Prophet::Server::Dispatcher'; sub show_template { if(ref($_[0])) { # called in oo context. do it now my $self = shift; my $template = shift; $self->server->show_template($template, @_); } else { my $template = shift; return sub { my $self = shift; $self->server->show_template($template, @_); }; } } 1; App-SD-0.75/lib/App/SD/Server/View.pm0000644000175000017500000005552211604653213016017 0ustar spangspanguse warnings; use strict; package App::SD::Server::View; use base 'Prophet::Server::View'; use URI::file; use Template::Declare::Tags; use Prophet::Server::ViewHelpers; use App::SD::Model::Ticket; use App::SD::Model::Comment; use App::SD::Collection::Ticket; my @BASIC_PROPS = qw(status milestone component owner reporter due created tags description); sub page_box { my ($id, $title, $component) = (@_); div { { id is $id }; { h2 { $title}; show($component)} }; } template '' => page { 'Project overview'} content { my $self = shift; div { { class is 'stats sidebar'}; page_box('components', 'Components', 'component_list'); page_box('statuses', 'Statuses', 'status_list'); page_box('milestones', 'Milestones', 'milestone_list'); }; div { { class is 'overview'}; h2 { 'Your active tickets for '. $self->app_handle->setting( label => 'default_milestone' )->get()->[0];}; show('/tickets/hot'); }; }; template 'hot_tickets' => page {'Your open tickets for the current milestone'} content { show('/tickets/hot'); }; template 'all_tickets' => page {'All tickets'} content { shift->show_tickets( sub {1}); }; template 'milestones' => page {'Project milestones'} content { show 'milestone_list'; }; template 'status_list' => sub { show('property_list','status'); }; template 'milestone_list' => sub { show('property_list', 'milestone') }; template 'component_list' => sub { show('property_list', 'component')}; template 'property_list' => sub { my $self = shift; my $property_name = shift; my $props = $self->app_handle->setting( label => ( $property_name =~ /s$/ ? $property_name . "es" : $property_name . 's' ) )->get(); my %counts = map { $_ => 0 } @$props; $self->find_tickets( sub { my $ticket = shift; return if ($property_name ne 'status' && !$ticket->has_active_status); $counts{ $ticket->prop($property_name) || '' }++}); my $total = 0; $total += $_ for values %counts; div { { class is 'pagesection' }; ul { my @order = grep {$_ ne ''} keys %counts; if ( defined $counts{''} && $counts{''} > 0) { push @order, ''; } foreach my $prop ( @order) { li { div { {class is 'bar-wrapper'} ; div { { class is 'bar'; ($total ? style is ("width: ". int(( ($counts{$prop} ||0)/ $total) * 100 )."%") : ()) }; outs(' '); };}; outs ( ($counts{$prop} ||'0') . " - "); a { { href is $self->server->make_link_relative( '/' . $property_name . '/' . ($prop ||'')) } ( $prop ? $prop : 'None' ) } } } } } }; template 'status' => page { 'Status: ' . ( $_[1] || 'none' ) } content { my $self = shift; my $status = shift || '' ; $self->show_tickets( sub {my $item = shift; ( ( $item->prop('status') || '' ) eq $status ) ? 1 : 0; } ); }; template 'component' => page { 'Component: ' . ( $_[1] || 'none' ) } content { my $self = shift; my $component = shift || '' ; $self->show_tickets( sub {my $item = shift; ( ( $item->prop('component') || '' ) eq $component && $item->has_active_status ) ? 1 : 0; } ); }; template 'milestone' => page { 'Milestone: ' . ( $_[1] || 'none' ) } content { my $self = shift; my $milestone = shift; $self->show_tickets( sub {my $item = shift; ( ( $item->prop('milestone') || '' ) eq ($milestone || '') && $item->has_active_status ) ? 1 : 0; } ); }; sub show_tickets { my $self = shift; my $tickets = $self->find_tickets(@_); show( '/ticket_list', $tickets ); } sub find_tickets { my $self = shift; my $callback = shift; my $tickets = App::SD::Collection::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); $tickets->matching($callback); return $tickets; } template edit_ticket => page { my $self = shift; my $id = shift; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); $ticket->load(($id =~ /^\d+$/ ? 'luid' : 'uuid') =>$id); $ticket->luid.": ".$ticket->prop('summary'); } content { my $self = shift; my $id = shift; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); $ticket->load(($id =~ /^\d+$/ ? 'luid' : 'uuid') =>$id); $self->ticket_page_actions($ticket); form { my $f = function( record => $ticket, action => 'update', order => 1, name => 'edit-ticket' ); div { { class is 'ticket-props'}; for my $prop ('summary') { div { { class is "widget $prop"}; widget( function => $f, prop => $prop, autocomplete => 0 ) }; } for my $prop (qw(status component milestone)){ div { { class is "widget $prop"}; widget( function => $f, prop => $prop ) }; } div { class is 'other-props'; for my $prop (@BASIC_PROPS) { next if $prop =~ /^(?:status|component|milestone|created|description)$/; div { { class is "widget $prop"}; widget( function => $f, prop => $prop ) }; } }; div { { class is "widget description"}; widget( function => $f, prop => 'description', type => 'textarea', autocomplete => 0) }; }; div { class is 'submit'; input { attr { value => 'Save', type => 'submit' } }; }; div { class is 'comment-form'; h2 { 'Add a comment' }; my $c = function( record => App::SD::Model::Comment->new( app_handle => $self->app_handle ), action => 'create', order => 2, name => 'update-ticket-comment' ); hidden_param( function => $c, prop => 'ticket', value => $ticket->uuid); for my $prop (qw(content)) { div { widget( function => $c, prop => $prop, type => 'textarea', autocomplete => 0)}; } }; div { class is 'submit'; input { attr { value => 'Save', type => 'submit' } }; }; }; }; template new_ticket => page {'Create a new ticket'} content { my $self = shift; form { { class is 'create-ticket'}; my $f = function( record => App::SD::Model::Ticket->new( app_handle => $self->app_handle ), action => 'create', order => 1, name => 'create-ticket' ); div { class is 'ticket-props'; for my $prop ('summary') { div { { class is "widget $prop" }; widget( function => $f, prop => $prop, autocomplete => 0 ); }; } for my $prop (qw(status component milestone)){ div { {class is 'widget '.$prop}; widget( function => $f, prop => $prop ) }; } div { class is 'other-props'; for my $prop (@BASIC_PROPS) { next if $prop =~ /^(?:status|component|milestone|created|description)$/; div { {class is 'widget '.$prop}; widget( function => $f, prop => $prop ) }; } div { {class is 'widget description'}; widget( function => $f, prop => 'description', type => 'textarea', autocomplete => '0' ) }; } }; div { class is 'submit'; input { attr { value => 'Save', type => 'submit' } }; }; div { class is 'comment-form'; h2 { 'Initial comments on this ticket' }; my $c = function( record => App::SD::Model::Comment->new( app_handle => $self->app_handle ), action => 'create', order => 2, name => 'create-ticket-comment' ); param_from_function( function => $c, prop => 'ticket', from_function => $f, from_result => 'record_uuid' ); for my $prop (qw(content)) { div { widget( function => $c, prop => $prop, type => 'textarea', autocomplete => 0)}; } div { class is 'submit'; input { attr { value => 'Save', type => 'submit' } }; } } }; }; template footer => sub { div { id is 'project-versions'; outs("SD $App::SD::VERSION - Issue tracking for the distributed age - ". " Prophet $Prophet::VERSION"); } }; template header => sub { my $self = shift; my $title = shift; outs_raw($self->page_nav->render_as_menubar) if ($self->page_nav); div{ class is 'logowrapper'; img { src is '/static/sd/images/sd.png'; alt is 'SD Logo', class is 'logo' }; }; div { class is 'project-name'; " for ".$self->app_handle->setting( label => 'project_name' )->get()->[0]}; h1 { $title }; }; template '/tickets/hot' => sub { my $self = shift; my $current_milestone = $self->app_handle->setting( label => 'default_milestone' )->get()->[0]; $self->show_tickets( sub { my $item = shift; if ( $item->has_active_status && ( $item->prop('milestone') || '' ) eq $current_milestone && ( ( $item->prop('owner') || '' ) eq ( $item->app_handle->config->get( key => 'user.email-address' ) || '') || !$item->prop('owner') ) ) { return 1; } else { return undef; } } ); }; template '/tickets/open' => sub { my $self = shift; $self->show_tickets (sub { my $item = shift; return $item->has_active_status ? 1 : 0; }); }; private template 'ticket_list' => sub { my $self = shift; my $tickets = shift; my $id = substr(rand(10),2); # hack to get a unique id div { { class is 'ticket-list'}; table { { class is 'tablesorter'; id is $id; }; thead { row { th { 'id'}; th {'Status'}; th {'Milestone'}; th {'Component'}; th {'Owner'}; th {'Reporter'}; th {'Due'}; th {'Created'}; } }; tbody { for my $ticket (@$tickets) { row { cell { class is 'id'; $self->ticket_link( $ticket => $ticket->luid ); }; for (qw|status milestone component owner reporter due created|) { cell { class is $_; $ticket->prop($_) }; } cell { class is 'summary'; $self->ticket_link( $ticket => $ticket->prop('summary') ); }; } } }; }}; script {outs_raw(qq{ \$(document).ready(function() { \$("#@{[$id]}").tablesorter(); } ); } ); outs_raw('$("td.created,td.due").prettyDateTag(); setInterval(function(){ $("td.created,td.due").prettyDateTag(); }, 5000);') }; }; template 'history' => page { my $self = shift; 'History'; } content { my $self = shift; my $latest = $self->app_handle->handle->latest_sequence_no; my $start = shift || $latest; my $end = $start - 20; $end = 1 if $end < 1; my @changesets; $self->app_handle->handle->traverse_changesets( reverse => 1, after => $end, until => $start, callback => sub { my %args = (@_); push @changesets, $args{changeset}; } ); div { { class is 'log'}; my $nav = sub { div {{ class is 'nav'}; if ($end > 1 ) { a {{ class is 'prev', href is $self->server->make_link_relative('/history/'.($end-1)) }; 'Earlier' }; } if ($start < $latest) { a {{ class is 'next', href is $self->server->make_link_relative ( '/history/'.(( $start+21 < $latest) ? ($start+21) : $latest)) }; 'Later' }; } } }; $nav->(); show( 'format_history', changesets => \@changesets, change_filter => sub {1}, sort_changesets => sub { sort {$b->sequence_no <=> $a->sequence_no} @_ }, change_header => sub { my $change = shift; if ( $change->record_type eq 'ticket' ) { my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); $ticket->load( uuid => $change->record_uuid ); h2 { a { { href is $self->server->make_link_relative( '/ticket/' . $ticket->uuid ); class is 'ticket-summary'; }; $ticket->prop('summary'); }; span { { class is 'ticket-id' }; ' (' . ( $ticket->luid || '' ) . ')'; }; } } elsif ($change->record_type eq 'comment') { my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); my $id; for ( $change->prop_changes ) { if ( $_->name eq 'ticket' ) { $id = $_->new_value } } return unless ($id); $ticket->load( uuid => $id ) ; h2 { outs('Comment on: '); a {{ href is $self->server->make_link_relative('/ticket/' . $ticket->uuid); class is 'ticket-summary' }; $ticket->prop('summary') }; span { { class is 'ticket-id'}; ' (' . ($ticket->luid ||''). ')'}; } } } ); $nav->(); } }; template 'show_ticket_history' => page { my $self = shift; my $id = shift; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); $ticket->load(($id =~ /^\d+$/ ? 'luid' : 'uuid') =>$id); $ticket->luid.": ".($ticket->prop('summary') || '(No summary)'); } content { my $self = shift; my $id = shift; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); $ticket->load(($id =~ /^\d+$/ ? 'luid' : 'uuid') =>$id); $self->ticket_page_actions($ticket); show('format_history', changesets => [$ticket->changesets], change_filter => sub { my $change = shift; return $ticket->uuid eq $change->record_uuid ? 1 : 0}, ); }; template 'show_ticket' => page { my $self = shift; my $id = shift; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); $ticket->load(($id =~ /^\d+$/ ? 'luid' : 'uuid') =>$id); $ticket->luid.": ".($ticket->prop('summary') ||'(No summary)'); } content { my $self = shift; my $id = shift; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, handle => $self->app_handle->handle ); $ticket->load(($id =~ /^\d+$/ ? 'luid' : 'uuid') =>$id); $self->ticket_page_actions($ticket); show ticket_basics => $ticket; show ticket_attachments => $ticket; show ticket_comments => $ticket; }; sub ticket_page_actions { my $self = shift; my $ticket = shift; ul { {class is 'actions'}; li { a {{ href is $self->server->make_link_relative('/ticket/'.$ticket->uuid.'/view')}; 'Show'}; }; li { a {{ href is $self->server->make_link_relative('/ticket/'.$ticket->uuid.'/edit')}; 'Update'}; } unless($self->server->static); li { a {{ href is $self->server->make_link_relative('/ticket/'.$ticket->uuid.'/history')}; 'History'}; }; }; } sub _by_creation_date { $a->prop('created') cmp $b->prop('created') }; private template 'ticket_basics' => sub { my $self = shift; my $ticket = shift; my %props = %{$ticket->get_props}; div { { class is 'ticket-props'}; div { class is 'widget uuid'; label { 'UUID' }; div { { class is 'value uuid'}; $ticket->uuid; } }; for my $key (qw'status component milestone', (grep {$_ ne 'description'} (@BASIC_PROPS, (sort keys %props)))){ next unless defined $props{$key}; next if ($key =~ m{(?:summary)}); next if ($key =~ /.{8}-.{4}-.{4}-.{12}-id/); div { class is 'widget '.$key; label {$key}; div { { class is 'value ' . $key }; $props{$key}; } }; delete $props{$key}; }; if ($props{description} ) { div { class is 'widget description'; label {'description'}; div { { class is 'value description' }; outs($props{description}); } }; } }; script { outs_raw('$("div.created,div.due").prettyDateTag(); setInterval(function(){ $("div.created,div.due").prettyDateTag(); }, 5000);') }; }; template ticket_attachments => sub { my $self = shift; my $ticket = shift; }; private template format_history => sub { my $self = shift; my %args = (changesets => undef, change_filter => undef, change_header => undef, sort_changesets => sub { sort {$a->created cmp $b->created} @_ }, @_); dl { { class is 'history' }; for my $changeset ( $args{sort_changesets}->( @{$args{changesets}} )) { dt { span { { class is 'created' }; $changeset->created; }; span { { class is 'creator' }; $changeset->creator || i {'Missing author'}; }; span { class is 'source_info'; span { { class is 'original_sequence_no' }; $changeset->original_sequence_no; }; span { { class is 'original_source_uuid' }; $self->app_handle->display_name_for_replica($changeset->original_source_uuid); }; }; }; dd { for my $change ( $changeset->changes ) { if ( $args{change_filter}->($change)) { if ($args{change_header}) { $args{change_header}->($change); } ul { li { outs_raw($_) } for (grep {$_} map { show_history_prop_change($_) } ( $change->prop_changes )); } } else { i { 'Something else changed - It was ' . $change->record_type . " ".$change->record_uuid}; } } } } }; script { outs_raw( '$("span.created").prettyDateTag(); setInterval(function(){ $("span.created").prettyDateTag(); }, 5000);' ); }; }; sub show_history_prop_change { my $pc = shift; if ( defined $pc->old_value && defined $pc->new_value ) { span { class is 'property'; $pc->name } . span { class is 'prose'; ' changed from ' } . span { class is 'value old'; $pc->old_value } . span { class is 'prose'; " to " } . span { class is 'value new'; $pc->new_value }; } elsif ( defined $pc->new_value ) { span { class is 'property'; $pc->name } . span { class is 'prose'; ' set to '} . span { class is 'value new'; $pc->new_value } } elsif ( defined $pc->new_value ) { span { class is 'property'; $pc->name } . ' ' . span { class is 'value old'; $pc->new_value } . span { class is 'prose'; ' deleted'}; } } template ticket_comments => sub { my $self = shift; my $ticket = shift; my @comments = sort {$a->prop('created') cmp $b->prop('created')} @{ $ticket->comments }; if (@comments) { h2 { { class is 'conmments'}; 'Comments'}; ul { { class is 'comments' }; for my $comment (@comments) { show('ticket_comment', $comment); } } script { outs_raw('$("span.created").prettyDateTag(); setInterval(function(){ $("span.created").prettyDateTag(); }, 5000);') }; } }; template ticket_comment => sub { my $self = shift; my $comment = shift; li { span { { class is 'metadata' }; span { class is 'created'; $comment->prop('created') }; outs(" "); span { class is 'creator'; $comment->prop('creator') }; } div { class is 'content'; if ( !$comment->prop('content') ) { i {'No body was entered for this comment'}; } elsif ( $comment->prop('content_type') && $comment->prop('content_type') =~ m{text/html}i ) { outs_raw( $comment->prop('content') ); } else { div { class is 'content-pre'; $comment->prop('content');}; } } } }; sub ticket_link { my $self = shift; my $ticket = shift; my $label = shift; span { class is 'ticket-link'; a { { class is 'ticket'; href is $self->server->make_link_relative( '/ticket/' . $ticket->uuid."/view"); }; $label; } }; } 1; App-SD-0.75/lib/App/SD/ForeignReplica.pm0000644000175000017500000003640611604653213016530 0ustar spangspangpackage App::SD::ForeignReplica; use Any::Moose; use Params::Validate qw/:all/; use Try::Tiny; use URI; extends 'Prophet::ForeignReplica'; has uuid => ( lazy => 1, isa => 'Str', is => 'ro', default => sub { my $self = shift; $self->uuid_for_url( $self->_uuid_url ); } ); =head2 save_username_and_token( $username, $token ) Saves the given username and token to the replica-specific config file, so the user doesn't have to enter it every time. =cut sub save_username_and_token { my ($self, $username, $password) = @_; # make sure replica is initialized, since this method is generally called # in the BUILD method of an object, which makes it end up being called # before the initialize call in clone $self->app_handle->handle->after_initialize( sub { shift->app_handle->set_db_defaults } ); $self->app_handle->handle->initialize; my $replica_username_key = 'replica.' . $self->scheme . ":" . $self->{url} . '.username'; my $replica_token_key = 'replica.' . $self->scheme . ":" . $self->{url} . '.secret_token'; if ( !$self->app_handle->config->get( key => $replica_username_key ) ) { print "Setting replica's username and token in the config file"; $self->app_handle->config->group_set( $self->app_handle->config->replica_config_file, [ { key => $replica_username_key, value => $username, }, { key => $replica_token_key, value => $password, } ], ); } } sub integrate_changeset { my $self = shift; my %args = validate( @_, { changeset => { isa => 'Prophet::ChangeSet' }, resolver => { optional => 1 }, resolver_class => { optional => 1 }, resdb => { optional => 1 }, conflict_callback => { optional => 1 }, reporting_callback => { optional => 1 } } ); my $changeset = $args{'changeset'}; return if $self->last_changeset_from_source( $changeset->original_source_uuid) >= $changeset->original_sequence_no; $self->SUPER::integrate_changeset(%args); } =head2 integrate_change $change $changeset Given a change (and the changeset it's part of), this routine will load the push encoder for the foreign replica's type and call integrate_change on it. To avoid publishing prophet-private data, It skips any change with a record type that record_type starts with '__'. This is probably a bug. =cut sub integrate_change { my $self = shift; my ( $change, $changeset ) = validate_pos( @_, { isa => 'Prophet::Change' }, { isa => 'Prophet::ChangeSet' }, ); # don't push internal records return if $change->record_type =~ /^__/; Prophet::App->require( $self->push_encoder()); my $recoder = $self->push_encoder->new( { sync_source => $self } ); $recoder->integrate_change($change,$changeset); } =head2 record_pushed_transactions Walk the set of transactions on the ticket whose id you've passed in, looking for updates by the 'current user' which happened after start_time and before now. Then mark those transactions as ones that originated in SD, so we don't accidentally push them later. =over =item ticket =item changeset =item start_time =back =cut sub record_pushed_transactions { my $self = shift; my %args = validate( @_, { ticket => 1, changeset => { isa => 'Prophet::ChangeSet' }, start_time => 1} ); my $earliest_valid_txn_date; # walk through every transaction on the ticket, starting with the latest for my $txn ( $self->get_txn_list_by_date($args{ticket}) ) { # walk backwards through all transactions on the ticket we just updated # Skip any transaction where the remote user isn't me, this might # include any transaction RT created with a scrip on your behalf next unless $txn->{creator} eq $self->foreign_username; # get the completion time _after_ we do our next round trip to rt to # try to make sure a bit of lag doesn't skew us to the wrong side of a # 1s boundary if (!$earliest_valid_txn_date){ my $change_window = time() - $args{start_time}; # skip any transaction created more than 5 seconds before the push # started. I can't think of any reason that number shouldn't be 1, # but clocks are fickle $earliest_valid_txn_date = $txn->{created} - ($change_window + 5); } last if $txn->{created} < $earliest_valid_txn_date; # if the transaction id is older than the id of the last changeset # we got from the original source of this changeset, we're done last if $txn->{id} <= $self->app_handle->handle->last_changeset_from_source( $args{changeset}->original_source_uuid); # if the transaction from RT is more recent than the most recent # transaction we got from the original source of the changeset # then we should record that we sent that transaction upstream $self->record_pushed_transaction( transaction => $txn->{id}, changeset => $args{'changeset'}, record => $args{'ticket'} ); } } =head2 record_pushed_transaction $foreign_transaction_id, $changeset Record that this replica was the original source of $foreign_transaction_id (with changeset $changeset) =cut sub record_pushed_transaction { my $self = shift; my %args = validate( @_, { transaction => 1, changeset => { isa => 'Prophet::ChangeSet' }, record => 1 } ); my $key = join('-', "foreign-txn-from" , $self->uuid , 'record' , $args{record} , 'txn' , $args{transaction} ); my $value = join(':', $args{changeset}->original_source_uuid, $args{changeset}->original_sequence_no ); $self->store_local_metadata($key => $value); } =head2 foreign_transaction_originated_locally $transaction_id $foreign_record_id Given a transaction id, will return true if this transaction originated in Prophet and was pushed to the foreign replica or originated in the foreign replica and has already been pulled to the Prophet replica. This is a mapping of all the transactions we have pushed to the remote replica we'll only ever care about remote sequence #s greater than the last transaction # we've pulled from the remote replica once we've done a pull from the remote replica, we can safely expire all records of this type for the remote replica (they'll be obsolete) We use this cache to avoid integrating changesets we've pushed to the remote replica when doing a subsequent pull =cut sub foreign_transaction_originated_locally { my $self = shift; my ( $id, $record ) = validate_pos( @_, 1, 1 ); return $self->fetch_local_metadata( "foreign-txn-from-" . $self->uuid . '-record-' . $record . '-txn-' . $id ); } sub traverse_changesets { my $self = shift; my %args = validate( @_, { after => 1, callback => 1, before_load_changeset_callback => { type => CODEREF, optional => 1}, reporting_callback => { type => CODEREF, optional => 1 }, } ); Prophet::App->require( $self->pull_encoder()); my $recoder = $self->pull_encoder->new( { sync_source => $self } ); my ( $changesets ) = $recoder->run( after => $args{'after'} ); for my $changeset (@$changesets) { if ( $args{'before_load_changeset_callback'} ) { my $continue = $args{'before_load_changeset_callback'}->( changeset_metadata => $self->_construct_changeset_index_entry($changeset) ); next unless $continue; } $args{callback}->( changeset => $changeset, after_integrate_changeset => sub { $self->record_last_changeset_from_replica( $changeset->original_source_uuid => $changeset->original_sequence_no ); # We're treating each individual ticket in the foreign system # as its own 'replica' because of that, we need to hint to the # push side of the system what the most recent txn on each # ticket it has. my $previously_modified = App::SD::Util::string_to_datetime( $self->upstream_last_modified_date || ''); my $created_datetime = App::SD::Util::string_to_datetime( $changeset->created ); $self->record_upstream_last_modified_date( $changeset->created ) if ( ( $created_datetime ? $created_datetime->epoch : 0 ) > ( $previously_modified ? $previously_modified->epoch : 0 ) ); } ); $args{reporting_callback}->($changeset) if ($args{reporting_callback}); } } sub _construct_changeset_index_entry { my $self = shift; my $changeset = shift; return [ $changeset->sequence_no, $changeset->original_source_uuid, $changeset->original_sequence_no, $changeset->calculate_sha1 ]; } sub remote_uri_path_for_id { die "your subclass needs to implement this to be able to ". "map a remote id to /ticket/id or soemthing"; } =head2 uuid_for_remote_id $id lookup the uuid for the remote record id. If we don't find it, construct it out of the remote url and the remote uri path for the record id; =cut sub uuid_for_remote_id { my ( $self, $id ) = @_; return $self->_lookup_uuid_for_remote_id($id) ||$self->_url_based_uuid_for_remote_ticket_id( $id); } sub _lookup_uuid_for_remote_id { my $self = shift; my ($id) = validate_pos( @_, 1 ); return $self->fetch_local_metadata( 'local_uuid_for_'. $self->_url_based_uuid_for_remote_ticket_id($id)); } sub _set_uuid_for_remote_id { my $self = shift; my %args = validate( @_, { uuid => 1, remote_id => 1 } ); return $self->store_local_metadata('local_uuid_for_'. $self->_url_based_uuid_for_remote_ticket_id( $args{'remote_id'} ), $args{uuid} ); } sub _url_based_uuid_for_remote_ticket_id { my $self = shift; my $id = shift; return $self->uuid_for_url( $self->remote_url . $self->remote_uri_path_for_id( $id ) ); } # This mapping table stores uuids for tickets we've synced from a remote # database Basically, if we created the ticket to begin with, then we'll know # its uuid if we pulled the ticket from the foreign replica then its uuid will # be generated based on a UUID-from-ticket-url scheme sub remote_id_for_uuid { my ( $self, $uuid_or_luid ) = @_; require App::SD::Model::Ticket; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, type => 'ticket' ); $ticket->load( $uuid_or_luid =~ /^\d+$/? 'luid': 'uuid', $uuid_or_luid ) or do { warn "couldn't load ticket #$uuid_or_luid"; return undef; }; my $prop = $self->uuid . '-id'; my $id = $ticket->prop( $prop ) or warn "ticket #$uuid_or_luid has no property '$prop'"; return $id; } sub _set_remote_id_for_uuid { my $self = shift; my %args = validate( @_, { uuid => 1, remote_id => 1 } ); require App::SD::Model::Ticket; my $ticket = App::SD::Model::Ticket->new( app_handle => $self->app_handle, type => 'ticket' ); $ticket->load( uuid => $args{'uuid'} ); $ticket->set_props( props => { $self->uuid.'-id' => $args{'remote_id'} } ); } =head2 record_remote_id_for_pushed_record When pushing a record created within the prophet cloud to a foreign replica, we need to do bookkeeping to record the prophet uuid to remote id mapping. =cut sub record_remote_id_for_pushed_record { my $self = shift; my %args = validate( @_, { uuid => 1, remote_id => 1 } ); $self->_set_uuid_for_remote_id(%args); $self->_set_remote_id_for_uuid(%args); } sub record_upstream_last_modified_date { my $self = shift; my $date = shift; return $self->store_local_metadata('last_modified_date' => $date); } sub upstream_last_modified_date { my $self = shift; return $self->fetch_local_metadata('last_modified_date'); } =head2 login_loop Loop on prompting for username/password until login is successful; user can abort with ^C. Saves username and password to the replica's configuration file upon successful login. params: - uri # login url - username # optional; a pre-seeded username - password # optional; a pre-seeded password - username_prompt # optional; custom username prompt - secret_prompt # optional; custom secret prompt - login_callback # coderef of code that attempts login; should throw exception # on error - catch_callback # optional; process thrown exception message (e.g. munge # in some way and then print to STDERR) returns: ($username, $password) =cut sub login_loop { my $self = shift; my %args = @_; my $login_successful = 0; my ($username, $password); my %login_args = ( uri => $args{uri}, username => $username ); $login_args{username_prompt} = $args{username_prompt} if $args{username_prompt}; $login_args{secret_prompt} = $args{secret_prompt} if $args{secret_prompt}; # allow prompting for just password if username already specified # and vice-versa for password # if both are specified, we still want to loop in case the # credentials are wrong $login_args{username} = $args{username} if $args{username}; $login_args{password} = $args{password} if $args{password}; while (!$login_successful) { ( $username, $password ) = $self->prompt_for_login(%login_args); try { $args{login_callback}->($self, $username, $password); $login_successful = 1; } catch { if ($args{catch_callback}) { $args{catch_callback}->($_); } else { warn "\n$_\n\n"; } # in the case of a failed login, reset username/password # to nothing so we re-prompt for both in the case of # having used saved values ($login_args{username}, $login_args{password}) = (undef, undef); }; $self->foreign_username($username) if ($username); } # only save username/password if login was successful $self->save_username_and_token( $username, $password ); return ($username, $password); } =head2 extract_auth_from_uri( $uri_string ) Given a server URI string, possibly containing auth info, extract the auth info if it exists. Also sets the remote_url and url attribute to the server URI with the auth information removed. returns: ($username, $password) =cut sub extract_auth_from_uri { my ($self, $uri_string) = @_; my $uri = URI->new($uri_string); my ($username, $password); if ( $uri->can('userinfo') && ( my $auth = $uri->userinfo ) ) { ( $username, $password ) = split /:/, $auth, 2; $uri->userinfo(undef); } $self->remote_url("$uri"); $self->url("$uri"); return ($username, $password); } sub foreign_username { die "replica class must implement foreign_username"; } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/Server.pm0000644000175000017500000000325211552666431015106 0ustar spangspangpackage App::SD::Server; use Any::Moose; extends 'Prophet::Server'; has with_browser => ( isa => 'Bool', is => 'rw', default => 0, ); =head2 database_bonjour_name Returns the name this database should use to announce itself via bonjour =cut sub database_bonjour_name { my $self = shift; my $name = $self->app_handle->setting( label => 'project_name' )->get->[0]; my $uuid = $self->handle->db_uuid; return "$name ($uuid)"; } sub css { return shift->SUPER::css(@_), "/static/sd/css/main.css"; } sub js { return shift->SUPER::js(@_); } # open up a browser after the server has been started (basically a # hook for the browser command) sub after_setup_listener { my $self = shift; local $SIG{CHLD}; # allow browser to be run with system() if ( $self->with_browser ) { $self->open_browser( url => 'http://localhost:' . $self->port ); } } sub open_browser { my $self = shift; my %args = (@_); my $opener = $self->open_url_cmd; if (!$opener) { warn "I'm unable to figure out what browser I should open for you.\n"; return; } system($opener, $args{url}) && die "Couldn't run $opener: $!"; } sub open_url_cmd { my $self = shift; if ( $^O eq 'darwin' ) { return 'open'; } elsif ( $^O eq 'MSWin32' ) { return 'start'; } for my $cmd (qw|x-www-browser htmlview gnome-open gnome-moz-remote firefox iceweasel opera www-browser w3m lynx|) { my $cmd_path = `which $cmd`; chomp($cmd_path); if ( $cmd_path && -f $cmd_path && -x _ ) { return $cmd_path; } } } no Any::Moose; 1; App-SD-0.75/lib/App/SD/Test.pm0000644000175000017500000001443211552666431014561 0ustar spangspangpackage App::SD::Test; use warnings; use strict; require Prophet::Test; use Test::More; use File::Spec; use File::Temp (); use Test::Script::Run qw(:all); use base qw/Exporter/; our @EXPORT = qw(create_ticket_ok update_ticket_ok create_ticket_with_editor_ok create_ticket_comment_ok get_uuid_for_luid get_luid_for_uuid get_ticket_info run_ok run_output_matches run_output_matches_unordered run_script is_script_output); delete $ENV{'PROPHET_APP_CONFIG'}; $ENV{'EDITOR'} = '/bin/true'; $Prophet::Test::CLI_CLASS = 'App::SD::CLI'; our ($A, $B, $C, $D); BEGIN { # create a blank config file so per-user configs don't break tests my $tmp_config = File::Temp->new( UNLINK => 0 ); print $tmp_config ''; close $tmp_config; print "setting SD_CONFIG to " . $tmp_config->filename . "\n"; $ENV{'SD_CONFIG'} = $tmp_config->filename; $ENV{'PROPHET_EMAIL'} = 'nobody@example.com'; $ENV{'USER'} ||= 'nobody'; } =head2 create_ticket_ok ARGS Creates a new ticket, passing ARGS along to the creation command (after the props separator). Returns a list of the luid and uuid of the newly created ticket. =cut sub create_ticket_ok { my @args = (@_); local $Test::Builder::Level = $Test::Builder::Level + 1; run_output_matches( 'sd', [ 'ticket', 'create', '--', @args ], [qr/Created ticket (.*?)(?{ $A = $1})\s+\((.*)(?{ $B = $2 })\)/] ); my ( $uuid, $luid ) =($B,$A); return ( $luid, $uuid ); } =head2 update_ticket_ok ID ARGS Updates the ticket #ID, passing ARGS along to the update command. Returns nothing interesting. =cut sub update_ticket_ok { my ($id, @args) = (@_); local $Test::Builder::Level = $Test::Builder::Level + 1; run_output_matches( 'sd', [ 'ticket', 'update', $id, '--', @args ], [qr/ticket \d+\s+\([^)]*\)\s+updated\./i] ); } =head2 create_ticket_comment_ok ARGS Creates a new ticket comment, passing ARGS along to the creation command. Returns a list of the luid and uuid of the newly created comment. =cut sub create_ticket_comment_ok { my @args = (@_); local $Test::Builder::Level = $Test::Builder::Level + 1; run_output_matches( 'sd', [ 'ticket', 'comment', 'create', @args ], [qr/Created comment (.*?)(?{ $A = $1})\s+\((.*)(?{ $B = $2 })\)/] ); my ( $uuid, $luid ) = ($B, $A); return ( $luid, $uuid ); } =head2 create_ticket_ok luid Takes a LUID and returns the corresponding UUID. Returns undef if none can be found. =cut sub get_uuid_for_luid { my $luid = shift; my ($ok, $out, $err) = run_script( 'sd', [ 'ticket', 'show', '--batch', '--id', $luid ]); if ($out =~ /^id: \d+ \((.*)\)/m) { return $1; } return undef; } =head2 get_luid_for_uuid UUID Takes a UUID and returns the corresponding LUID. Returns undef if none can be found. =cut sub get_luid_for_uuid { my $uuid = shift; my ($ok, $out, $err) = run_script( 'sd', [ 'ticket', 'show', '--batch', '--id', $uuid ]); if ($out =~ /^id: (\d+)/m) { return $1; } return undef; } =head2 create_ticket_with_editor_ok [ '--verbose' ... ] Creates a ticket and comment at the same time using a spawned editor. It's expected that C<$ENV{VISUAL}> has been frobbed into something non-interactive, or this test will just hang forever. Any extra arguments passed in will be passed on to sd ticket create. Returns a list of the ticket luid, ticket uuid, comment luid, and comment uuid. =cut sub create_ticket_with_editor_ok { my @extra_args = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; run_output_matches( 'sd', [ 'ticket', 'create', @extra_args ], [qr/Created ticket (.*?)(?{ $A = $1})\s+\((.*)(?{ $B = $2 })\)/, qr/Created comment (.*?)(?{ $C = $1})\s+\((.*)(?{ $D = $2 })\)/] ); my ( $ticket_uuid, $ticket_luid, $comment_uuid, $comment_luid )= ($B,$A,$D,$C); return ( $ticket_luid, $ticket_uuid, $comment_luid, $comment_uuid ); } =head2 update_ticket_with_editor_ok TICKET_LUID, TICKET_UUID [ '--verbose' ] Updates the ticket given by TICKET_UUID using a spawned editor. It's expected that C<$ENV{VISUAL}> has been frobbed into something non-interactive, or this test will just hang forever. Any extra arguments passed in will be passed on to sd ticket update. Returns the luid and uuid of the comment created during the update (both will be undef if none is created). =cut sub update_ticket_with_editor_ok { my $self = shift; my $ticket_luid = shift; my $ticket_uuid = shift; my @extra_args = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; run_output_matches( 'sd', [ 'ticket', 'update', $ticket_uuid, @extra_args ], [ qr/Updated ticket (.*?)\s+\((.*)\)/, qr/Created comment (.*?)(?{ $A = $1 })\s+\((.*)(?{ $B = $2 })\)/ ] ); my ($comment_luid, $comment_uuid) = ($A, $B); return ( $comment_luid, $comment_uuid ); } =head2 update_ticket_comment_with_editor_ok COMMENT_LUID, COMMENT_UUID Updates the ticket comment given by COMMENT_UUID using a spawned editor. It's expected that C<$ENV{VISUAL}> has been frobbed into something non-interactive, or this test will just hang forever. =cut sub update_ticket_comment_with_editor_ok { my $self = shift; my ($comment_luid, $comment_uuid) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; run_output_matches( 'sd', [ 'ticket', 'comment', 'update', $comment_uuid ], [ 'Updated comment '.$comment_luid . ' ('. $comment_uuid .')'] ); } =head2 get_ticket_info LUID/UUID Returns a hash reference with information about ticket. =cut sub get_ticket_info { my $id = shift; my ($ok, $out, $err) = run_script( 'sd', [qw(ticket show --batch --verbose --id), $id ]); my @lines = split /\n/, $out; my %res; my $section = ''; while ( defined( $_ = shift @lines ) ) { if ( /^= ([A-Z]+)\s*$/ ) { $section = lc $1; next; } next unless $section; if ( $section eq 'metadata' ) { next unless /^(\w+):\s*(.*?)\s*$/; $res{$section}{$1} = $2; } } if ( $res{'metadata'}{'id'} ) { @{ $res{'metadata'} }{'luid', 'uuid'} = ( $res{'metadata'}{'id'} =~ /^(\d+)\s+\((.*?)\)\s*$/ ); } return \%res; } 1; App-SD-0.75/lib/App/SD/Collection/0000755000175000017500000000000011604745260015367 5ustar spangspangApp-SD-0.75/lib/App/SD/Collection/Comment.pm0000644000175000017500000000030611552666431017332 0ustar spangspangpackage App::SD::Collection::Comment; use Any::Moose; extends 'Prophet::Collection'; use constant record_class => 'App::SD::Model::Comment'; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/Collection/Ticket.pm0000644000175000017500000000030411552666435017155 0ustar spangspangpackage App::SD::Collection::Ticket; use Any::Moose; extends 'Prophet::Collection'; use constant record_class => 'App::SD::Model::Ticket'; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/Collection/Attachment.pm0000644000175000017500000000031311552666431020016 0ustar spangspangpackage App::SD::Collection::Attachment; use Any::Moose; extends 'Prophet::Collection'; use constant record_class => 'App::SD::Model::Attachment'; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/0000755000175000017500000000000011604745260013703 5ustar spangspangApp-SD-0.75/lib/App/SD/CLI/Dispatcher.pm0000644000175000017500000001744411552666431016345 0ustar spangspang#!/usr/bin/env perl package App::SD::CLI::Dispatcher; use Prophet::CLI::Dispatcher -base; use Any::Moose; require Prophet::CLIContext; use File::Basename; Prophet::CLI::Dispatcher->add_command_prefix('App::SD::CLI::Command'); # "sd ?about" => "sd help about" rewrite qr/^\?(.*)/ => sub { "help ".($1||'') }; # 'sd about' -> 'sd help about', 'sd copying' -> 'sd help copying' rewrite [ ['about', 'copying'] ] => sub { "help $1" }; on qr'^(?!help)' => sub { my $self = shift; my $cmd = $_; if ($self->context->has_arg('help')) { run("help $cmd", $self, @_); } elsif ($self->context->has_arg('version') || $self->context->has_arg('V') ) { $self->context->delete_arg('version'); $self->context->delete_arg('V'); run("version", $self); } else { next_rule; } }; under help => sub { on [ [ 'intro', 'init' ] ] => run_command('Help::Intro'); on about => run_command('Help::About'); on config => run_command('Help::Config'); on copying => run_command('Help::Copying'); on commands => run_command('Help::Commands'); on [ ['summary-format', 'ticket.summary-format', 'ticket_summary_format'] ] => run_command('Help::ticket_summary_format'); on [ ['author', 'authors'] ] => run_command('Help::Authors'); on [ ['environment', 'env'] ] => run_command('Help::Environment'); on [ ['ticket', 'tickets'] ] => run_command('Help::Tickets'); on [ ['attach', 'attachment', 'attachments'] ] => run_command('Help::Attachments'); on [ ['comment', 'comments'] ] => run_command('Help::Comments'); on [ ['setting', 'settings'] ] => run_command('Help::Settings'); on [ ['history', 'log'] ] => run_command('Help::History'); on [ ['alias', 'aliases'] ] => run_command('Help::Aliases'); on [ ['ticket', 'attachment', 'comment'], ['list', 'search', 'find'], ] => run_command('Help::Search'); # anything else under ticket, e.g. 'ticket close' etc. should be covered # in the tickets help on qr/^ticket/ => run_command('Help::Tickets'); on [ ['search', 'list', 'find'] ] => run_command('Help::Search'); on [ ['sync', 'push', 'pull', 'publish', 'server', 'browser', 'clone'] ] => run_command('Help::Sync'); on qr/^(\S+)$/ => sub { my $self = shift; my $topic = $1; die "Cannot find help on topic '$topic'. Try '".$self->cli->get_script_name()."help'?\n"; }; }; on help => run_command('Help'); on qr'.*' => sub { my $self = shift; unless ( $self->cli->app_handle->local_replica_url || $self->cli->context->has_arg('h') ) { print join "\n", "", "It appears that you haven't specified a local replica path.", "You can do so by setting the SD_REPO environment variable.", "", " 'sd help intro' will tell you a bit about how to get started with sd.", " 'sd help' will show show you a list of help topics.", "", ""; exit 1; } next_rule; }; on qr'.*' => sub { my $self = shift; my $command = $_; next_rule if $command =~ /^(?:shell|clone|init)$|(config|alias(?:es)?)/; next_rule if $self->cli->app_handle->handle->replica_exists; print join("\n","No SD database was found at " . $self->cli->app_handle->handle->url(), qq{Type "} . $self->cli->get_script_name(). qq{help init" or "}. $self->cli->get_script_name().qq{help environment" for tips on how to sort that out.}); exit 1; }; on browser => run_command('Browser'); # allow doing some things backwards -- e.g. 'list tickets' etc. on qr/^(\w+)\s+tickets?(.*)$/ => sub { my $self = shift; my $primary = $1; my $secondary = $2; next_rule if $primary eq 'help'; my $cmd = join( ' ', grep { $_ ne '' } 'ticket',$primary, $secondary); my @orig_argv = @{$self->cli->context->raw_args}; my ($subcommand, undef) = (shift @orig_argv, shift @orig_argv); $self->cli->run_one_command( 'ticket', $subcommand, @orig_argv); }; under ticket => sub { # all these might possibly have IDs tacked onto the end on qr/^((?:comment\s+)?(?:comments?|update|edit|show|details|display|delete|del|rm|history|claim|take|resolve|basics|close)) $Prophet::CLIContext::ID_REGEX$/i => sub { my $self = shift; $self->context->set_id_from_primary_commands; run("ticket $1", $self, @_); }; on [ [ 'new' , 'create' ] ] => run_command('Ticket::Create'); on [ [ 'show' , 'display' ] ] => run_command('Ticket::Show'); on [ [ 'update' , 'edit' ] ] => run_command('Ticket::Update'); on [ [ 'search', 'list', 'ls' ] ] => run_command('Ticket::Search'); on review => run_command('Ticket::Review'); on details => run_command('Ticket::Details'); on basics => run_command('Ticket::Basics'); on comment => run_command('Ticket::Comment'); on comments => run_command('Ticket::Comments'); under [ [ 'give', 'assign' ] ] => sub { on [qr/^$Prophet::CLIContext::ID_REGEX$/, qr/^\S+$/] => sub { my $self = shift; my ($id, $owner) = ($1, $2); $self->context->set_arg(id => $id); $self->context->set_arg(type => 'ticket'); $self->context->set_prop(owner => $owner); $self->context->set_type_and_uuid; run('ticket update', $self, @_); }; on qr/^(.*)$/ => sub { die "Usage: give \n"; }; }; on [ ['resolve', 'close'] ] => sub { my $self = shift; $self->context->set_prop(status => 'closed'); run('ticket update', $self, @_); }; # simulate a 'claim' command by setting the owner prop and passing # off to update on [ [ 'claim', 'take' ] ] => sub { my $self = shift; my $email = $self->context->app_handle->current_user_email; if ($email) { $self->context->set_prop(owner => $email); run('ticket update', $self, @_); } else { die "Could not determine email address to assign ticket to!\n". "Set the 'user.email-address' config variable.\n"; } }; under comment => sub { on create => run_command('Ticket::Comment::Create'); on update => run_command('Ticket::Comment::Update'); }; under attachment => sub { on create => run_command('Ticket::Attachment::Create'); on [ [ 'create', 'new' ], qr/^$Prophet::CLIContext::ID_REGEX$/ ] => sub { my $self = shift; $self->context->set_id_from_primary_commands; run('ticket attachment create', $self, @_); }; on search => run_command('Ticket::Attachment::Search'); }; }; under attachment => sub { on qr/^(.*)\s+($Prophet::CLIContext::ID_REGEX)$/i => sub { my $self = shift; my $next = $1; my $id = $2; $self->context->set_id($id); run("attachment $next", $self, @_); }; on content => run_command('Attachment::Content'); on create => run_command('Attachment::Create'); }; # allow type to be specified via primary commands, e.g. # 'sd ticket display --id 14' -> 'sd display --type ticket --id 14' on qr{^(ticket|comment|attachment) \s+ (.*)}xi => sub { my $self = shift; my $type = $1; my $redispatch_to = $2; $self->context->set_arg(type => $type); run($redispatch_to, $self, @_); }; redispatch_to('Prophet::CLI::Dispatcher'); on '' => run_command('Shell'); on qr/^(.*)$/ => sub { my $self = shift; my $command = $1; die "The command you ran, '$command', could not be found. Perhaps running '" .$self->cli->get_script_name."help' would help?\n"; }; sub run_command { Prophet::CLI::Dispatcher::run_command(@_) } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/NewReplicaCommand.pm0000644000175000017500000001052211552666431017575 0ustar spangspangpackage App::SD::CLI::NewReplicaCommand; use Any::Moose 'Role'; # steal email from $ENV{EMAIL} or prompt, and prompt to edit settings sub new_replica_wizard { my $self = shift; my %args = ( edit_settings => 1, @_, ); # VCS wrappers themselves should take care of settings email addresses on # init/clone from VCS configuration, don't put that here # non-interactive option is useful for testing and scriptability unless ( $self->has_arg('non-interactive') ) { # don't prompt for configuration if there's already a user-wide email set if ( ! defined $self->config->get( key => 'user.email-address' ) ) { print "\nYou need an email address configured to use SD. I'll try" ." to find one.\n"; if ( $ENV{PROPHET_EMAIL} ) { $self->_migrate_email_from_env( 'PROPHET_EMAIL' ); } } if ( ! defined $self->config->get( key => 'user.email-address' ) ) { if ( $ENV{EMAIL} ) { $self->_migrate_email_from_env( 'EMAIL' ); } } # if we still don't have an email, ask if ( ! defined $self->config->get( key => 'user.email-address' ) ) { $self->_prompt_email; } # new replicas probably want to change settings right away, # at least to change the project name ;) $self->_prompt_edit_settings if $args{edit_settings}; } # this message won't print if the user has a ~/.sdrc, which is # probably a pretty good indication that they're not new my $script = $self->cli->get_script_name; print <<"END_MSG" unless -f $self->config->user_file; If you're new to SD, you can find out what to do now by looking at '${script}help intro' and '${script}help tickets'. You can see a list of all help topics with '${script}help'. Have fun! END_MSG } # default is the replica-specific config file sub _prompt_which_config_file { my $self = shift; my $email = shift; print "\nUse '$email' for (a)ll your bug databases, (j)ust" ." this one,\nor (n)ot at all? [a/J/n] "; chomp( my $response = ); my $config_file = lc $response eq 'a' ? $self->config->user_file : lc $response eq 'n' ? undef : $self->config->replica_config_file; return $config_file; } sub _migrate_email_from_env { my $self = shift; my $var = shift; print "Found '$ENV{$var}' in \$$var.\n"; my $config_file = $self->_prompt_which_config_file( $ENV{$var} ); if ( $config_file ) { $self->config->set( key => 'user.email-address', value => $ENV{$var}, filename => $config_file, ); print " - added email '$ENV{$var}' to\n $config_file\n"; } } sub _prompt_email { my $self = shift; Prophet::CLI->end_pager(); # XXX where does this get turned back on? print "\nCouldn't determine an email address to attribute your SD changes to.\n"; my $email; while ( ! $email ) { print "What email shall I use? "; chomp( $email = ); } my $use_dir_config = $self->prompt_choices( 'j', 'a', 'Use this for (a)ll your SD databases or (j)ust this one?' ); my $config_file = $use_dir_config ? $self->config->replica_config_file : $self->config->user_file; $self->config->set( key => 'user.email-address', value => $email, filename => $config_file, ); print " - added email '$email' to\n $config_file\n"; } sub _prompt_edit_settings { my $self = shift; my $prompt_for_settings = $self->prompt_Yn( "\nWant to edit your new bug database's settings now?" ); if ( $prompt_for_settings ) { my @classes = App::SD::CLI::Dispatcher->class_names('Settings'); for my $class (@classes) { $self->app_handle->try_to_require($class) or next; # reset args for new command my $args = { edit => 1, }; $self->context->mutate_attributes( args => $args ); my $command = $class->new( uuid => $self->context->uuid, cli => $self->cli, context => $self->context, ); $command->run(); } } } no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/0000755000175000017500000000000011604745260015261 5ustar spangspangApp-SD-0.75/lib/App/SD/CLI/Command/Clone.pm0000644000175000017500000000262411552666431016667 0ustar spangspangpackage App::SD::CLI::Command::Clone; use Any::Moose; extends 'Prophet::CLI::Command::Clone'; with 'App::SD::CLI::NewReplicaCommand'; sub ARG_TRANSLATIONS { shift->SUPER::ARG_TRANSLATIONS(), # this arg is used in the new_replica_wizard sub n => 'non-interactive', }; sub usage_msg { my $self = shift; my $cmd = $self->cli->get_script_name; return <<"END_USAGE"; usage: ${cmd}clone --from [--as ] [--non-interactive] | --local Options: -n | --non-interactive - Don't prompt to specify email address for new database --as - Save an alias for this source, which can later be used instead of the URL. --local - Probe the local network for mDNS-advertised replicas and list them. END_USAGE } override run => sub { my $self = shift; # clone dies if the target replica already exists, so no need # to worry about not running the wizard if the clone doesn't run $self->SUPER::run(); Prophet::CLI->end_pager(); # Prompt for SD setup (specifically email address for changes) after the # clone, but *don't* immediately edit the database's settings, since a # cloned database should have already been setup previously. $self->new_replica_wizard( edit_settings => 0 ); }; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Shell.pm0000644000175000017500000000225511552666431016676 0ustar spangspangpackage App::SD::CLI::Command::Shell; use Any::Moose; extends 'Prophet::CLI::Command::Shell'; has project_name => ( isa => 'Str', is => 'rw', lazy => 1, default => sub { my $self = shift; if ( $self->app_handle->handle->replica_exists ) { return $self->app_handle->setting( label => 'project_name' )->get()->[0]; } else { return 'No database found'; } } ); sub usage_msg { my $self = shift; my $cmd = $self->cli->get_script_name; return <<"END_USAGE"; usage: ${cmd}\[cmd] ${cmd}--version | -V END_USAGE } sub preamble { my $self = shift; my @out = ( "SD for " . $self->project_name . " ($App::SD::VERSION; Prophet $Prophet::VERSION)", 'Type "help", "about", or "copying" for more information.' ); if ( !$self->app_handle->handle->replica_exists ) { push @out, '', "No SD database was found at " . $self->app_handle->handle->url(), 'Type "help init" and "help environment" for tips on how to sort that out.'; } return join( "\n", @out ); } sub prompt { my $self = shift; return $self->project_name . "> "; } 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/0000755000175000017500000000000011604745260016504 5ustar spangspangApp-SD-0.75/lib/App/SD/CLI/Command/Ticket/Comment/0000755000175000017500000000000011604745260020106 5ustar spangspangApp-SD-0.75/lib/App/SD/CLI/Command/Ticket/Comment/Update.pm0000644000175000017500000000142211552666431021671 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Comment::Update; use Any::Moose; extends 'Prophet::CLI::Command::Update'; override run => sub { my $self = shift; $self->print_usage if $self->has_arg('h'); $self->require_uuid; my $record = $self->_load_record; my @prop_set = $self->prop_set; # we don't want to do prop: value editing by default for comments since # it's just a blob of text if (!@prop_set || $self->has_arg('edit')) { my $updated_comment = $self->edit_text($record->prop('content')); $record->set_prop(name => 'content', value => $updated_comment); print "Updated comment " . $record->luid . " (" . $record->uuid . ")\n"; } else { super(); } }; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Comment/Create.pm0000644000175000017500000000201211552666431021646 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Comment::Create; use Any::Moose; extends 'Prophet::CLI::Command::Create'; with 'App::SD::CLI::Model::TicketComment'; with 'App::SD::CLI::Command'; sub ARG_TRANSLATIONS { shift->SUPER::ARG_TRANSLATIONS(), f => 'file', m => 'content' }; sub usage_msg { my $self = shift; my ($cmd, $type_and_subcmd) = $self->get_cmd_and_subcmd_names; return <<"END_USAGE"; usage: ${cmd}${type_and_subcmd} [--edit] ${cmd}${type_and_subcmd} -- content="message here" END_USAGE } # override args to feed in that ticket's uuid as an argument to the comment sub run { my $self = shift; $self->print_usage if $self->has_arg('h'); $self->require_uuid; my $content = $self->get_content(type => 'comment', default_edit => 1); die "Aborted.\n" if length($content) == 0; $self->set_prop(ticket => $self->uuid); $self->set_prop(content => $content); $self->SUPER::run(@_); } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Comments.pm0000644000175000017500000000173611552666431020642 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Comments; use Any::Moose; extends 'Prophet::CLI::Command::Search'; with 'Prophet::CLI::RecordCommand'; with 'App::SD::CLI::Command'; with 'App::SD::CLI::Model::Ticket'; override usage_msg => sub { my $self = shift; my $cmd = $self->cli->get_script_name; return <<"END_USAGE"; usage: ${cmd}ticket comments END_USAGE }; sub run { my $self = shift; $self->print_usage if $self->has_arg('h'); my $record = $self->_get_record_object; $self->require_uuid; $record->load( uuid => $self->uuid ); if (@{$record->comments}) { for my $entry ($self->sort_by_prop( 'created' => $record->comments)) { print "id: ".$entry->luid." (".$entry->uuid.")\n"; print "created: ".$entry->prop('created')."\n\n"; print $entry->prop('content')."\n\n"; } } else { print "No comments found\n"; } } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Search.pm0000644000175000017500000000704611552666431020262 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Search; use Any::Moose; extends 'Prophet::CLI::Command::Search'; with 'App::SD::CLI::Command'; sub ARG_TRANSLATIONS { shift->SUPER::ARG_TRANSLATIONS(), s => 'sort', g => 'group' }; override usage_msg => sub { my $self = shift; my $script = $self->cli->get_script_name; my @primary_commands = @{ $self->context->primary_commands }; # if primary commands was only length 1, the type was not specified # and we should indicate that a type is expected push @primary_commands, '' if @primary_commands <= 1; my $type_and_subcmd = join( q{ }, @primary_commands ); return <<"END_USAGE"; usage: ${script}${type_and_subcmd} ${script}${type_and_subcmd} -- summary=~foo status!~new|open END_USAGE }; # frob the sort routine before running prophet's search command override run => sub { my $self = shift; $self->print_usage if $self->has_arg('h'); if ( (!$self->has_arg('sort') || !$self->arg('sort')) && $self->app_handle->config->get( key => 'ticket.default-sort') ) { $self->set_arg( 'sort' => $self->app_handle->config->get( key => 'ticket.default-sort' ) ); } if ( (!$self->has_arg('group') || !$self->arg('group')) && $self->app_handle->config->get( key => 'ticket.default-group') ) { $self->set_arg( 'group' => $self->app_handle->config->get( key => 'ticket.default-group') ); } # sort output by given prop if user specifies --sort if ( $self->has_arg('sort') && $self->arg('sort') && ( $self->arg('sort') ne 'none' ) ) { my $sort_prop = $self->arg('sort'); my $sort_undef_last = $self->app_handle->config->get( key => $self->type . ".$sort_prop.sort-undef-last" ); $self->sort_routine( sub { my $records = shift; return $self->sort_by_prop( $sort_prop, $records, $sort_undef_last ); } ); } if ( $self->has_arg('group') && $self->arg('group') && ( $self->arg('group') ne 'none' ) ) { $self->group_routine( sub { my $records = shift; my $groups = $self->group_by_prop( $self->arg('group') => $records ); if ( $self->arg('group') eq 'milestone' ) { my $order = $self->app_handle->setting( label => 'milestones' ) ->get(); my %group_hash = map { $_->{'label'} => $_->{'records'} } @$groups; my $sorted_groups = [ map { { label => $_, records => ( delete $group_hash{$_} || [] ) } } @$order ]; return [ @$sorted_groups, ( map { { label => $_, records => $group_hash{$_} } } keys %group_hash ) ]; } return $groups; } ); } $self->SUPER::run(@_); }; # implicit status != closed override default_match => sub { my $self = shift; my $ticket = shift; return 1 if $ticket->has_active_status(); return 0; }; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Comment.pm0000644000175000017500000000031211552666431020444 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Comment; use Any::Moose; extends 'App::SD::CLI::Command::Ticket::Comment::Create'; sub type { 'comment' } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Review.pm0000644000175000017500000001212011552666431020303 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Review; use Any::Moose; extends 'App::SD::CLI::Command::Ticket::Search'; #with 'App::SD::CLI::Command'; override usage_msg => sub { my $self = shift; my $script = $self->cli->get_script_name; my @primary_commands = @{ $self->context->primary_commands }; # if primary commands was only length 1, the type was not specified # and we should indicate that a type is expected push @primary_commands, '' if @primary_commands <= 1; my $type_and_subcmd = join( q{ }, @primary_commands ); return <<"END_USAGE"; usage: ${script}${type_and_subcmd} ${script}${type_and_subcmd} -- summary=~foo status!~new|open END_USAGE }; before run => sub { Prophet::CLI->end_pager(); }; our %ACTIONS = (); our %INFO = ( ); after out_record => sub { my $self = shift; my $record = shift; $self->out_widget( $record ); ASK_AGAIN: print "Update> "; my $do = ; chomp $do; $do =~ s/^\s+//; $do =~ s/\s+$//; return unless length $do; my @list = split /\+/, $do; my $ask_again = 0; foreach my $do ( @list ) { my $action = $ACTIONS{ $do }; unless ( $action ) { print "No action bound to '$do', try again...\n"; $ask_again = 1; next; } next unless $action->{'action'}; my $name = 'action_'. $action->{'action'}; unless ( $self->can($name) ) { print "Not implemented, patches are welcome\n"; $ask_again = 1; next; } $self->$name( $record, %$action ); print "Done $do\n"; } goto ASK_AGAIN if $ask_again; }; sub out_widget { my $self = shift; my $record = shift; $self->prepare_actions($record) unless keys %ACTIONS; print "show [b] basics or [d] details\n"; foreach my $property ( @{ $INFO{'properties'} } ) { my $prop_shortcut = $INFO{'shortcuts'}{$property}; print "$property:\n"; print "\t"; my $current = $record->prop($property); my $not_first = 0; foreach my $value ( @{ $INFO{'values'}{$property} } ) { print ", " if $not_first++; print "[". $prop_shortcut . $INFO{vshortcuts}{$property}{$value} ."] $value"; print "*" if $value eq $current; } print "\n"; } } sub action_property { my $self = shift; my $record = shift; my %args = ( name => undef, value => undef, @_ ); $record->set_prop( name => $args{'name'}, value => $args{'value'} ); } sub prepare_actions { my $self = shift; my $record = shift; %ACTIONS = ( b => { action => 'show', value => 'basics' }, d => { action => 'show', value => 'details' }, ); my @reserved = keys %ACTIONS; my $app_handle = $record->app_handle; my @props = @{ $app_handle->setting( label => 'common_ticket_props' )->get }; foreach my $property ( @props ) { my $plural_form = $self->plural_noun( $property ); # XXX: dirty hack next unless $app_handle->database_settings->{$plural_form}; my @values = @{ $app_handle->setting( label => $plural_form )->get }; next unless @values; $INFO{'values'}{$property} = \@values; my $shortcut = $INFO{'shortcuts'}{$property} = $self->shortcut( $property, @reserved ); push @reserved, $shortcut; $ACTIONS{ $shortcut } = {}; } @props = grep $INFO{'values'}{ $_ }, @props; $INFO{'properties'} = \@props; foreach my $property ( @props ) { my @reserved = (); foreach my $value ( @{ $INFO{'values'}{$property} } ) { my $shortcut = $self->shortcut( $value, @reserved ); push @reserved, $shortcut; $ACTIONS{ $INFO{'shortcuts'}{$property} . $shortcut } = { action => 'property', name => $property, value => $value, }; $INFO{'vshortcuts'}{$property}{$value} = $shortcut; } } } sub plural_noun { my $self = shift; my $noun = shift; # simple plural form generation, full info on # http://www.csse.monash.edu.au/~damian/papers/HTML/Plurals.html return $noun.'es' if $noun =~ /[cs]h$/; return $noun.'es' if $noun =~ /ss$/; return $noun if $noun =~ s/([aeo]l|[^d]ea|ar)f$/$1ves/; return $noun if $noun =~ s/([nlw]i)fe$/$1ves/; return $noun.'s' if $noun =~ /[aeiou]y$/; return $noun if $noun =~ s/y$/ies/; return $noun.'s' if $noun =~ /[aeiou]o$/; return $noun.'es' if $noun =~ /o$/; return $noun.'es' if $noun =~ /s$/; return $noun.'s'; } sub shortcut { my $self = shift; my $word = shift; my @reserved = @_; for (my $i = 0; $i < length $word; $i++ ) { my $char = substr $word, $i, 1; return wantarray? ($char, $i) : $char unless grep $_ eq $char, @reserved; } for (my $i = 1; $i <= length $word; $i++ ) { my $prefix = substr $word, 0, $i; return wantarray? ($prefix, $i) : $prefix unless grep $_ eq $prefix, @reserved; } return $word, 0; } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Basics.pm0000644000175000017500000000034011552666431020247 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Basics; use Any::Moose; extends 'Prophet::CLI::Command::Show'; with 'App::SD::CLI::Command'; with 'App::SD::CLI::Model::Ticket'; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Update.pm0000644000175000017500000000645511552666431020302 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Update; use Any::Moose; use Params::Validate qw/validate/; extends 'Prophet::CLI::Command::Update'; with 'App::SD::CLI::Model::Ticket'; with 'App::SD::CLI::Command'; with 'Prophet::CLI::TextEditorCommand'; sub ARG_TRANSLATIONS { shift->SUPER::ARG_TRANSLATIONS(), a => 'all-props' }; sub usage_msg { my $self = shift; my $cmd = $self->cli->get_script_name; my @primary_commands = @{ $self->context->primary_commands }; # if primary commands was only length 1, the type was not specified # and we should indicate that a type is expected push @primary_commands, '' if @primary_commands <= 1; my $type_and_subcmd = join( q{ }, @primary_commands ); return <<"END_USAGE"; usage: ${cmd}${type_and_subcmd} --edit [--all-props] ${cmd}${type_and_subcmd} -- status=open END_USAGE } # use an editor to edit if no props are specified on the commandline, # allowing the creation of a new comment in the process override run => sub { my $self = shift; $self->print_usage if $self->has_arg('h'); $self->require_uuid; my $record = $self->_load_record; return super() if ($self->context->prop_names && !$self->has_arg('edit')); my $template_to_edit = $self->create_record_template($record); my $done = 0; while (!$done) { $done = $self->try_to_edit( template => \$template_to_edit, record => $record); } }; sub process_template { my $self = shift; my %args = validate( @_, { template => 1, edited => 1, record => 1 } ); my $record = $args{record}; my $updated = $args{edited}; my ( $props_ref, $comment ) = $self->parse_record_template($updated); no warnings 'uninitialized'; # if a formerly existing prop was removed from the output, delete it # (deleting is currently the equivalent of setting to '', and # we want to do this all in one changeset) for my $prop ( keys %{ $record->get_props } ) { next if ( grep { $_ eq $prop } $record->immutable_props ); $props_ref->{$prop} = '' if (!exists $props_ref->{$prop} && # only delete props if they were actually presented # for editing in the first place grep { $_ eq $prop } $record->props_to_show( { update => 1, verbose => $self->has_arg('all-props'), } ) ); } # don't add props that didn't change to the changeset for my $prop ( keys %$props_ref ) { delete $props_ref->{$prop} if $props_ref->{$prop} eq $record->prop($prop); } # set the new props if ( keys %$props_ref ) { my $error; local $@; eval { $record->set_props( props => $props_ref ) } or $error = $@ || "Something went wrong!"; return $self->handle_template_errors( error => $error, template_ref => $args{template}, bad_template => $updated ) if ($error); print 'Updated ticket ' . $record->luid . ' (' . $record->uuid . ")\n"; } else { print "No changes in properties.\n"; } $self->add_comment( content => $comment, uuid => $record->uuid ) if $comment; return 1; } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Create.pm0000644000175000017500000000505511552666431020256 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Create; use Any::Moose; use Params::Validate qw/validate/; extends 'Prophet::CLI::Command::Create'; with 'App::SD::CLI::Model::Ticket'; with 'App::SD::CLI::Command'; with 'Prophet::CLI::TextEditorCommand'; sub ARG_TRANSLATIONS { shift->SUPER::ARG_TRANSLATIONS(), e => 'edit' }; # use actual valid ticket props in the help message, and make note of the # interactive editing mode override usage_msg => sub { my $self = shift; my $cmd = $self->cli->get_script_name; my @primary_commands = @{ $self->context->primary_commands }; # if primary commands was only length 1, the type was not specified # and we should indicate that a type is expected push @primary_commands, '' if @primary_commands == 1; my $type_and_subcmd = join( q{ }, @primary_commands ); return <<"END_USAGE"; usage: ${cmd}${type_and_subcmd} -- summary=foo status=open ${cmd}${type_and_subcmd} [--edit] END_USAGE }; # we want to launch an $EDITOR window to grab props and a comment if no # props are specified on the commandline override run => sub { my $self = shift; $self->print_usage if $self->has_arg('h'); my @prop_set = $self->prop_set; my $record = $self->_get_record_object; # only invoke editor if no props specified on the commandline or edit arg specified return super() if (@{$self->prop_set} && !$self->has_arg('edit')); my $template_to_edit = $self->create_record_template(); my $done = 0; while (!$done) { $done = $self->try_to_edit( template => \$template_to_edit, record => $record); } }; sub process_template { my $self = shift; my %args = validate( @_, { template => 1, edited => 1, record => 1 } ); my $record = $args{record}; my $updated = $args{edited}; ( my $props_ref, my $comment ) = $self->parse_record_template($updated); for my $prop ( keys %$props_ref ) { $self->context->set_prop( $prop => $props_ref->{$prop} ); } my $error; local $@; eval { super(); } or chomp ($error = $@ || "Something went wrong!"); return $self->handle_template_errors( error => $error . "\n\nYou can bypass validation for a " ."property by appending a ! to it.", template_ref => $args{template}, bad_template => $updated, rtype => $record->type, ) if ($error); $self->add_comment( content => $comment, uuid => $self->record->uuid ) if $comment; return 1; } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Details.pm0000644000175000017500000000271311552666431020436 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Details; use Any::Moose; extends 'App::SD::CLI::Command::Ticket::Show'; sub by_creation_date { $a->prop('created') cmp $b->prop('created') }; sub usage_msg { my $self = shift; my ($cmd, $type_and_subcmd) = $self->get_cmd_and_subcmd_names; # XXX TODO Review these options return <<"END_USAGE"; usage: ${cmd}${type_and_subcmd} [options] Options are: -a|--all-props Show props even if they aren't common -b|--batch END_USAGE } override run => sub { my $self = shift; $self->print_usage if $self->has_arg('h'); $self->require_uuid; my $record = $self->_load_record; print "\n=head1 METADATA\n\n"; super(); my @attachments = sort by_creation_date @{$record->attachments}; if (@attachments) { print "\n=head1 ATTACHMENTS\n\n"; print $_->format_summary . "\n" for @attachments; } my @comments = sort by_creation_date @{$record->comments}; if (@comments) { print "\n=head1 COMMENTS\n\n"; for my $comment (@comments) { my $creator = $comment->prop('creator'); my $created = $comment->prop('created'); my $content = $comment->prop('content'); print "$creator: " if $creator; print "$created\n$content\n\n"; } } print "\n=head1 HISTORY\n\n"; print $record->history_as_string; }; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Attachment/0000755000175000017500000000000011604745260020574 5ustar spangspangApp-SD-0.75/lib/App/SD/CLI/Command/Ticket/Attachment/Search.pm0000644000175000017500000000062111552666431022342 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Attachment::Search; use Any::Moose; extends 'Prophet::CLI::Command::Search'; with 'Prophet::CLI::RecordCommand'; with 'App::SD::CLI::Model::Attachment'; sub type {'attachment'} sub get_search_callback { my $self = shift; return sub { shift->prop('ticket') eq $self->uuid ? 1 : 0; } } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Attachment/Create.pm0000644000175000017500000000132611552666431022343 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Attachment::Create; use Any::Moose; extends 'App::SD::CLI::Command::Attachment::Create'; sub ARG_TRANSLATIONS { shift->SUPER::ARG_TRANSLATIONS(), f => 'file' }; sub usage_msg { my $self = shift; my ($cmd, $type_and_subcmd) = $self->get_cmd_and_subcmd_names; return <<"END_USAGE"; usage: ${cmd}${type_and_subcmd} [--file ] END_USAGE } # override args to feed in that ticket's uuid as an argument to the comment sub run { my $self = shift; $self->print_usage if $self->has_arg('h'); $self->require_uuid; $self->set_prop(ticket => $self->uuid); $self->SUPER::run(@_); }; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Ticket/Show.pm0000644000175000017500000001156711552666431020000 0ustar spangspangpackage App::SD::CLI::Command::Ticket::Show; use Any::Moose; extends 'Prophet::CLI::Command::Show'; with 'App::SD::CLI::Command'; with 'App::SD::CLI::Model::Ticket'; sub ARG_TRANSLATIONS { shift->SUPER::ARG_TRANSLATIONS(), a => 'all-props', s => 'skip-history', h => 'with-history', b => 'batch'; } sub by_creation_date { ($a->can('created') ? $a->created : $a->prop('created') ) cmp ($b->can('created') ? $b->created : $b->prop('created') ) } sub usage_msg { my $self = shift; my $cmd = shift || 'show'; my $script = $self->cli->get_script_name; my $type = $self->type ? $self->type . q{ } : q{}; return <<"END_USAGE"; usage: ${script}${type}${cmd} [options] Options are: -a|--all-props Show props even if they aren't common -s|--skip-history Don't show ticket history -h|--with-history Show ticket history even if disabled in config -b|--batch END_USAGE } override run => sub { my $self = shift; $self->print_usage if $self->has_arg('h'); $self->require_uuid; my $record = $self->_load_record; # prophet uses --verbose to decide whether to show all declared props # or not (rather than just the ones returned by props_to_show), # but --all-props is more consistent with sd's behaviour in update/create if ( $self->has_arg('all-props') ) { $self->set_arg( 'verbose' => 1 ); } print "\n= METADATA\n\n"; super(); my @history = sort by_creation_date ( @{ $record->comments }, $record->changesets ); my @attachments = sort by_creation_date @{ $record->attachments }; if (@attachments) { print "\n= ATTACHMENTS\n\n"; $self->show_attachment($_) for @attachments; } # allow user to not display history by specifying the --skip-history # arg or setting ticket.no-implicit-history-display config item to a # true value (can be overridden with --with-history) if (!$self->has_arg('skip-history') && ( !$self->app_handle->config->get( key => 'ticket.no-implicit-history-display', as => 'bool', ) || $self->has_arg('with-history') ) ) { print "\n= HISTORY\n\n"; foreach my $item (@history) { if ( $item->isa('Prophet::ChangeSet') ) { $self->show_history_entry( $record, $item ); } elsif ( $item->isa('App::SD::Model::Comment') ) { $self->show_comment($item); } } } }; sub format_prop { my $self = shift; my $field = shift; my $value = shift; if ($self->has_arg('batch')) { return "$field: $value\n"; } else { return sprintf("%18.18s: %s\n",$field, $value); } } sub show_history_entry { my $self = shift; my $ticket = shift; my $changeset = shift; my $body = ''; for my $change ( $changeset->changes ) { next if $change->record_uuid ne $ticket->uuid; $body .= App::SD::CLI->format_change(change => $change) || next; $body .= "\n"; } return '' if !$body; $self->history_entry_header( $changeset->creator, $changeset->created, $changeset->original_sequence_no, $self->app_handle->display_name_for_replica($changeset->original_source_uuid), ); print $body; } sub show_attachment { my $self = shift; my $attachment = shift; print $attachment->format_summary . "\n"; } sub show_comment { my $self = shift; my $comment = shift; my $creator = $comment->prop('creator'); my $created = $comment->prop('created'); my $content_type = $comment->prop('content_type') || 'text/plain'; my $content = $comment->prop('content') || ''; my ($creation) = $comment->changesets(limit => 1); $self->history_entry_header($creator, $created,$creation->original_sequence_no, $self->app_handle->display_name_for_replica($creation->original_source_uuid)); print $self->format_comment($content_type, $content); print "\n\n"; } sub format_comment { my $self = shift; my $content_type = shift; my $content = shift; if ( $content_type =~ m{text/html}i ) { $content =~ s||\n|gismx; $content =~ s||\n|gismx; $content =~ s||*|gismx; $content =~ s||_|gismx; $content =~ s|(.*?)|$2 [link: $1 ]|gismx; $content =~ s|<.*?>||gismx; $content =~ s|\n\n|\n|gismx; } return $content; } sub history_entry_header { my $self = shift; my ($creator, $created, $sequence, $source) = (@_); print "="x80; print "\n"; printf "%s at %s\t\(%d@%s)\n", ( $creator || '(unknown)' ), $created, $sequence, $source; print "-"x80; print "\n"; } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Version.pm0000644000175000017500000000033411552666431017250 0ustar spangspangpackage App::SD::CLI::Command::Version; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; print $self->version ."\n"; } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help.pm0000644000175000017500000000326511552666431016521 0ustar spangspangpackage App::SD::CLI::Command::Help; use Any::Moose; extends 'Prophet::CLI::Command'; with 'App::SD::CLI::Command'; sub usage_msg { my $self = shift; my $cmd = $self->cli->get_script_name; return <<"END_USAGE"; usage: ${cmd}help [] END_USAGE } sub title { my $self = shift; } sub version { my $self = shift; "sd ".$App::SD::VERSION; } sub print_header { my $self = shift; my $title = shift; my $string = join(' - ', $self->version, $title); $self->print_usage if $self->has_arg('h'); print "\n".$string . "\n"; print '-' x ( length($string)); print "\n"; } sub run { my $self = shift; my ${cmd}= $self->cli->get_script_name; $self->print_header("Help Index"); print < -h'. EOF } #__PACKAGE__->meta->make_immutable; #no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Server.pm0000644000175000017500000000034611552666431017074 0ustar spangspangpackage App::SD::CLI::Command::Server; use Any::Moose; extends 'Prophet::CLI::Command::Server'; sub run { my $self = shift; $self->server->read_only(1) unless ($self->has_arg('writable')); $self->SUPER::run(); } 1; App-SD-0.75/lib/App/SD/CLI/Command/Publish.pm0000644000175000017500000001365411604653213017232 0ustar spangspangpackage App::SD::CLI::Command::Publish; use Any::Moose; extends 'Prophet::CLI::Command::Publish'; use Prophet::Util; use File::Path; use File::Spec; use HTML::TreeBuilder; use URI::file; use Try::Tiny; sub export_html { my $self = shift; my $path = $self->arg('path'); # if they specify both html and replica, then stick rendered templates # into a subdirectory. if they specify only html, assume they really # want to publish directly into the specified directory if ( $self->has_arg('replica') ) { $path = File::Spec->catdir( $path => 'html' ); mkpath( [$path] ); } $self->render_templates_into($path); } # helper methods for rendering templates sub render_templates_into { my $self = shift; my $dir = shift; require App::SD::Server; my $server = App::SD::Server::Static->new( read_only => 1, static => 1, app_handle => $self->app_handle ); $server->static(1); $server->setup_template_roots(); use CGI; my $file = "/"; { local $ENV{'REMOTE_ADDR'} = '127.0.0.1'; local $ENV{'REQUEST_METHOD'} = 'GET'; my $cgi = CGI->new(); my @links = ('/'); my $seen = {}; while ( my $file = shift @links ) { next if $seen->{$file}; local $ENV{'REQUEST_URI'} = $file; try { $cgi->path_info($file); my $content = $server->handle_request($cgi); if ( defined $content ) { my $page_links = []; ( $content, $page_links ) = $self->work_with_urls( $file, $content ); push @links, grep { !$seen->{$_} } @$page_links; $self->write_file( $dir, $file, $content ); $seen->{$file}++; } } catch { if ( $_ =~ /^REDIRECT (.*)$/ ) { my $new_file = $1; chomp($new_file); $self->handle_redirect( $dir, $file, $new_file ); unshift @links, $new_file; } elsif ($_) { # rethrow die $_; } }; } } } sub work_with_urls { my $self = shift; my $current_url = shift; my $content = shift; my $current_depth = () = $current_url =~ m{.+?/}g; #Extract Links from the file my $h = HTML::TreeBuilder->new; $h->no_space_compacting(1); $h->ignore_ignorable_whitespace(0); $h->parse_content($content); my $link_elements = $h->extract_links(qw(img href script style a link )); return ($content, []) unless @$link_elements; my $all_links = {}; #Grab each img src and re-write them so they are relative URL's foreach my $link_element (@$link_elements) { my $link = shift @$link_element; #URL value my $element = shift @$link_element; #HTML::Element Object $all_links->{$link}++; my $url = $link; if ( $url =~ m|/$| ) { $url .= "index.html" } elsif ($url !~ /\.\w{2,4}$/) { $url .= ".html"; } # if $url is absolute, let's make it relative if ( $url =~ s{^/}{} && $current_depth ) { $url = ( '../' x $current_depth ) . $url; } my ($attr) = grep { defined $element->attr($_) and $link eq $element->attr($_) } @{ $HTML::Tagset::linkElements{ $element->tag } }; $element->attr( $attr, $url ); } my @links; # we nned to turn every link into absolute, here is to find out dir info # e.g. if $current_url is '/foo/bar/baz.html', @dirs will be qw/foo bar/ my @dirs = grep { $_ } split m{/}, $current_url; # pop the page name like history.html pop @dirs; for my $link ( keys %$all_links ) { next unless $link; # we don't use ./ and file: link in pages, so they are bogus for us # more worse thing is './' will overwride some page with nothing next if $link eq './' || $link =~ /^file:/; # generally, if the link is not absolute, we need to find it. if ( $link !~ m{^/} ) { my $depth = $link =~ s{\.\./}{}g; my @tmp_dirs = @dirs; # remove trailing dirs according to $depth if ($depth) { pop @tmp_dirs while $depth--; } $link = '/' . join '/', @tmp_dirs, $link; } push @links, $link; } return $h->as_HTML, \@links; } sub handle_redirect { my $self = shift; my $dir = shift; my $file = shift; my $new_file = shift; my $redirected_from = File::Spec->catfile( $dir => $file ); my $redirected_to = File::Spec->catfile( $dir => $new_file ); { my $parent = Prophet::Util->updir($redirected_from); # mkpath succeeds (but returns nothing) if a directory already exists eval { mkpath( [$parent] ) }; if ( $@ ) { die "Failed to create directory " . $parent . " - for $redirected_to " . $@; } } if ( -d $redirected_from ) { $redirected_from .= "/index.html"; } link( $redirected_to, $redirected_from ); } sub write_file { my $self = shift; my $dir = shift; my $file = shift; my $content = shift; if ( $file =~ qr|/$| ) { $file .= "index.html" } elsif ($file !~ /\.\w{2,4}$/) { $file .= ".html"; } Prophet::Util->write_file( file => File::Spec->catfile( $dir => $file ), content => $content ); } __PACKAGE__->meta->make_immutable; no Any::Moose; package App::SD::Server::Static; use Any::Moose; extends 'App::SD::Server'; use Params::Validate; use JSON; sub log_request { } sub send_content { my $self = shift; my %args = validate( @_, { content => 1, content_type => 0, encode_as => 0, static => 0 } ); if ( $args{'encode_as'} && $args{'encode_as'} eq 'json' ) { $args{'content'} = to_json( $args{'content'} ); } return $args{'content'}; } sub _send_redirect { my $self = shift; my %args = validate( @_, { to => 1 } ); die "REDIRECT " . $args{to} . "\n"; } sub _send_404 {} __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Init.pm0000644000175000017500000000132011552666431016522 0ustar spangspangpackage App::SD::CLI::Command::Init; use Any::Moose; extends 'Prophet::CLI::Command::Init'; with 'App::SD::CLI::NewReplicaCommand'; sub usage_msg { my $self = shift; my $cmd = $self->cli->get_script_name; return <<"END_USAGE"; usage: ${cmd}init [--non-interactive] Options: -n | --non-interactive - Don't prompt to edit settings or specify email address for new database END_USAGE } sub ARG_TRANSLATIONS { shift->SUPER::ARG_TRANSLATIONS(), n => 'non-interactive', }; override run => sub { my $self = shift; $self->SUPER::run(); Prophet::CLI->end_pager(); $self->new_replica_wizard(); }; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Browser.pm0000644000175000017500000000063211552666431017247 0ustar spangspangpackage App::SD::CLI::Command::Browser; use Any::Moose; extends 'App::SD::CLI::Command::Server'; override run => sub { my $self = shift; $self->print_usage if $self->has_arg('h'); $self->server->with_browser(1); Prophet::CLI->end_pager(); print "Browser will be opened after server has been started.\n"; $self->SUPER::run(); }; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Log.pm0000644000175000017500000000507411552666431016352 0ustar spangspangpackage App::SD::CLI::Command::Log; use Any::Moose; extends 'Prophet::CLI::Command::Log'; use App::SD::CLI::Command::Ticket::Show; sub handle_changeset { my $self = shift; my $changeset = shift; print $changeset->as_string( skip_empty => 1, change_filter => sub { my $change = shift; return undef if $change->record_type eq '_merge_tickets'; if ($change->record_type eq 'comment') { } return 1; }, change_formatter => sub { App::SD::CLI->format_change(@_); }, change_header => sub { my $change = shift; $self->change_header($change)."\n".("-"x80)."\n"; }, header_callback => sub { my $c = shift; print "\n".("="x80) . "\n"; sprintf "%s - %s : %s@%s\n", $c->created, ( $c->creator || '(unknown)' ), $c->original_sequence_no, $self->app_handle->display_name_for_replica($c->original_source_uuid) ; } ); } sub change_header { my $self = shift; my $change = shift; if (my $sub = $self->can("change_header_".$change->record_type)) { return $sub->($self, $change); } else { return $self->change_header_generic($change); } } sub change_header_generic { my $self = shift; my $change = shift; return ucfirst($change->record_type) . " " . $self->app_handle->handle->find_or_create_luid( uuid => $change->record_uuid ) . " (" . $change->record_uuid . ")"; } sub change_header_comment { my $self = shift; my $change = shift; require App::SD::Model::Comment; my $c = App::SD::Model::Comment->new( app_handle => $self->app_handle ); $c->load(uuid => $change->record_uuid); if ($c->prop('ticket')) { my $t = $c->ticket; return "Comment on ticket " . $t->luid . " (".$t->prop('summary').")" } else { return "Comment on unknown ticket"; } } sub change_header_ticket { my $self = shift; my $change = shift; require App::SD::Model::Ticket; my $t = App::SD::Model::Ticket->new( app_handle => $self->app_handle ); $t->load(uuid => $change->record_uuid); unless ($t->uuid) { return $self->change_header_generic($change); } return "Ticket " . $self->app_handle->handle->find_or_create_luid( uuid => $change->record_uuid ) . " (".($t->prop('summary')||'').")" } __PACKAGE__->meta->make_immutable; no Any::Moose; App-SD-0.75/lib/App/SD/CLI/Command/Help/0000755000175000017500000000000011604745260016151 5ustar spangspangApp-SD-0.75/lib/App/SD/CLI/Command/Help/Sync.pm0000644000175000017500000001067611552666431017441 0ustar spangspangpackage App::SD::CLI::Command::Help::Sync; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Sharing ticket databases'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Attachments.pm0000644000175000017500000000164511552666431020774 0ustar spangspangpackage App::SD::CLI::Command::Help::Attachments; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Working with ticket attachments'); my ${cmd}= $self->cli->get_script_name; print < to_apply.patch Save the contents of attachment 567 to a file so the patch can be applied. EOF } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Config.pm0000644000175000017500000001001111552666431017711 0ustar spangspangpackage App::SD::CLI::Command::Help::Config; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Configuration Options'); my ${cmd}= $self->cli->get_script_name; print <.sort-undef-last = true When sorting on , setting this will make tickets where the property is undefined sort *after* any records where the property *is* defined. (The default is the opposite.) Useful for e.g. due dates. ticket.default-group = milestone Bug property to group tickets by when displaying lists of tickets. (Can be any property.) ticket.show.disable-history = 1 Don't display ticket history when running '${cmd}ticket show'. Can be overridden by passing the '--with-history' arg to the command. user.email-address = foo\@bar.com Specifies an email address to use as the default for tickets' reporter field. (Overrides the EMAIL environmental variable if that is also set.) server.default-port = 8080 Specifies a default port to use for the 'server' and 'browser' commands. Can still be overridden by passing '--port' to these commands. For information on environmental variables that can affect SD, see '${cmd}help environment'. EOF } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Comments.pm0000644000175000017500000000200411552666431020274 0ustar spangspangpackage App::SD::CLI::Command::Help::Comments; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Working with ticket comments'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Authors.pm0000644000175000017500000000100611552666431020135 0ustar spangspangpackage App::SD::CLI::Command::Help::Authors; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; my ${cmd}= $self->cli->get_script_name; $self->print_header("Authors"); print < Shawn Moore Christine Spang Jesse Vincent Casey West Simon Wistow EOF } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Intro.pm0000644000175000017500000000314611552666431017612 0ustar spangspangpackage App::SD::CLI::Command::Help::Intro; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Getting started with SD'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Search.pm0000644000175000017500000000441511552666431017724 0ustar spangspangpackage App::SD::CLI::Command::Help::Search; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Searching for and displaying tickets'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Environment.pm0000644000175000017500000000265111552666431021023 0ustar spangspangpackage App::SD::CLI::Command::Help::Environment; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Environment variables'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Commands.pm0000644000175000017500000000357311552666431020264 0ustar spangspangpackage App::SD::CLI::Command::Help::Commands; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Summary of SD commands'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Tickets.pm0000644000175000017500000000470611552666431020130 0ustar spangspangpackage App::SD::CLI::Command::Help::Tickets; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Creating and Updating tickets'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/About.pm0000644000175000017500000000217311552666431017570 0ustar spangspangpackage App::SD::CLI::Command::Help::About; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; my ${cmd}= $self->cli->get_script_name; $self->print_header('About SD'); print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Settings.pm0000644000175000017500000000214711552666431020317 0ustar spangspangpackage App::SD::CLI::Command::Help::Settings; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Database Settings'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Aliases.pm0000644000175000017500000000414411552666431020077 0ustar spangspangpackage App::SD::CLI::Command::Help::Aliases; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Command Aliases'); my ${cmd}= $self->cli->get_script_name; print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/Copying.pm0000644000175000017500000000241511552666431020125 0ustar spangspangpackage App::SD::CLI::Command::Help::Copying; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('License Terms (The MIT license)'); print <meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/ticket_summary_format.pm0000644000175000017500000000427011552666431023126 0ustar spangspangpackage App::SD::CLI::Command::Help::ticket_summary_format; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('The ticket.summary-format configuration option'); print < " and drawing from the options: modifiers: bold, dark, underline, underscore, reverse, concealed foreground colors: black, red, green, yellow, blue, magenta, cyan, white background colors: on_black, on_red, on_green, on_yellow, on_blue, on_magenta, on_cyan, on_white Modifiers, foreground colors, and background colors can be specified individually or just two of three, rather than having to specify all three. When printing the summary format for the ticket, the value of the given property for that ticket will be subbed into the format string (e.g. '%s') and any non-format characters in the format field will be printed as-is. If no format field is supplied with a given atom, '%s' is assumed. For more help on format strings, see http://perldoc.perl.org/functions/sprintf.html. EOF } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Help/History.pm0000644000175000017500000000233311552666431020155 0ustar spangspangpackage App::SD::CLI::Command::Help::History; use Any::Moose; extends 'App::SD::CLI::Command::Help'; sub run { my $self = shift; $self->print_header('Viewing Database History'); my ${cmd}= $self->cli->get_script_name; print <.. Shows the range of history starting at and ending at . Ranges can be specified using either sequence numbers or an offset from the most recent change, designated by LATEST~offset. Examples: ${cmd}log 0..5 Shows changes 0 through 5. ${cmd}log LATEST Shows the most recent change. ${cmd}log LATEST~4 Shows changes from 4 before the most recent change up to the most recent change. ${cmd}log 2..LATEST~5 Shows the second change up through 5 before the latest. ${cmd}log LATEST~10..LATEST~5 Shows changes from 10 before the latest to 5 before the latest. EOF } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Attachment/0000755000175000017500000000000011604745260017351 5ustar spangspangApp-SD-0.75/lib/App/SD/CLI/Command/Attachment/Content.pm0000644000175000017500000000066611552666431021335 0ustar spangspangpackage App::SD::CLI::Command::Attachment::Content; use Any::Moose; extends 'Prophet::CLI::Command::Show'; with 'App::SD::CLI::Model::Attachment'; with 'App::SD::CLI::Command'; sub run { my $self = shift; $self->print_usage if $self->has_arg('h'); my $record = $self->_get_record_object; $record->load(uuid => $self->uuid); print $record->prop('content'); } __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command/Attachment/Create.pm0000644000175000017500000000077111552666431021123 0ustar spangspangpackage App::SD::CLI::Command::Attachment::Create; use Any::Moose; extends 'Prophet::CLI::Command::Create'; with 'App::SD::CLI::Model::Attachment'; with 'App::SD::CLI::Command'; sub run { my $self = shift; $self->print_usage if $self->has_arg('h'); my $content = $self->get_content(type => 'attachment'); die "Aborted.\n" if length($content) == 0; $self->set_prop(content => $content); $self->SUPER::run(@_); }; __PACKAGE__->meta->make_immutable; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Model/0000755000175000017500000000000011604745260014743 5ustar spangspangApp-SD-0.75/lib/App/SD/CLI/Model/TicketComment.pm0000644000175000017500000000022111552666431020046 0ustar spangspangpackage App::SD::CLI::Model::TicketComment; use Any::Moose 'Role'; use constant record_class => 'App::SD::Model::Comment'; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Model/Ticket.pm0000644000175000017500000002034511552666431016534 0ustar spangspangpackage App::SD::CLI::Model::Ticket; use Any::Moose 'Role'; use Params::Validate qw(:all); use constant record_class => 'App::SD::Model::Ticket'; =head2 add_comment content => str, uuid => str A convenience method that takes a content string and a ticket uuid and creates a new comment record, for use in other commands (such as ticket create and ticket update). =cut sub add_comment { my $self = shift; validate(@_, { content => 1, uuid => 1 } ); my %args = @_; require App::SD::CLI::Command::Ticket::Comment::Create; $self->context->mutate_attributes( args => \%args ); my $command = App::SD::CLI::Command::Ticket::Comment::Create->new( uuid => $args{uuid}, cli => $self->cli, context => $self->context, type => 'comment', ); $command->run(); } =head2 metadata_separator A string of text that goes in the comment denoting the beginning of immutable ticket metadata in a string representing a ticket. Immutable ticket metadata includes things such as ticket id and creation date that are useful to display to the user when editing a ticket but are automatically assigned by sd and are not intended to be changed manually. =cut use constant metadata_separator => 'required ticket metadata (changes here will not be saved)'; use constant mutable_props_separator => 'edit ticket details below'; use constant comment_separator => 'add new ticket comment below'; =head2 create_record_template [ RECORD ] Creates a string representing a new record, prefilling default props and props specified on the command line. Intended to be presented to the user for editing using Ltry_to_edit> and then parsed using L. If RECORD is given, then we are updating that record rather than creating a new one, and the ticket string will be created from its props rather than prop defaults. =cut sub create_record_template { my $self = shift; my $record = shift; my $update; if ($record) { $update = 1 } else { $record = $self->_get_record_object; $update = 0; } my @do_not_edit = $record->immutable_props; my ( @metadata_order, @mutable_order ); my ( %immutable_props, %mutable_props ); # separate out user-editable props so we can both show all # the props that will be added to the new ticket and prevent # users from being able to break things by changing props # that shouldn't be changed, such as uuid # # filter out props we don't want to present for editing my %do_not_edit = map { $_ => 1 } @do_not_edit; for my $prop ( $record->props_to_show( # only call props_to_show with --verbose if we're in an update # because new tickets have no declared props { 'verbose' => ($self->has_arg('all-props') && $update), update => $update } ) ) { if ( $do_not_edit{$prop}) { if ( $prop eq 'id' && $update ) { # id isn't a *real* prop, so we have to mess with it some more push @metadata_order, $prop; $immutable_props{$prop} = $record->luid . ' (' . $record->uuid . ")"; } elsif ( !( ( $prop eq 'id' or $prop eq 'created' ) && !$update ) ) { push @metadata_order, $prop; # which came first, the chicken or the egg? # # we don't want to display id/created for ticket creates # because they can't by their nature be specified until the # ticket is actually created $immutable_props{$prop} = $update ? $record->prop($prop) : undef; } } else { push @mutable_order, $prop; $mutable_props{$prop} = $update ? $record->prop($prop) : undef; } } # fill in prop defaults if we're creating a new ticket if ( !$update ) { $record->default_props( \%immutable_props ); $record->default_props( \%mutable_props ); } # fill in props specified on the commandline (overrides defaults) if ( $self->has_arg('edit') ) { map { $mutable_props{$_} = $self->prop($_) if $self->has_prop($_) } @mutable_order; $self->delete_arg('edit'); } my $immutable_props_string = $self->_build_kv_pairs( order => \@metadata_order, data => \%immutable_props, verbose => $self->has_arg('verbose'), record => $record, ); my $mutable_props_string = $self->_build_kv_pairs( order => \@mutable_order, data => \%mutable_props, verbose => $self->has_arg('verbose'), record => $record, ); # glue all the parts together return join( "\n", $self->build_template_section( header => metadata_separator, data => $immutable_props_string ), $self->build_template_section( header => mutable_props_separator, data => $mutable_props_string ), $self->build_template_section( header => comment_separator, data => '' ) ); } sub _build_kv_pairs { my $self = shift; my %args = validate (@_, { order => 1, data => 1, verbose => 1, record => 1 }); my $string = ''; for my $prop ( @{$args{order}}) { # if called with --verbose, we print descriptions and valid values for # props (if they exist) if ( $args{verbose} ) { if ( my $desc = $self->app_handle->setting( label => 'prop_descriptions' )->get()->[0]->{$prop} ) { $string .= '# '.$desc."\n"; } if ( ($args{record}->recommended_values_for_prop($prop))[0] ) { my @valid_values = $args{record}->recommended_values_for_prop($prop); my $valid_vals_header = "# valid values for $prop:"; my $valid_vals_header_len = length $valid_vals_header; my $line_length = $valid_vals_header_len; $string .= $valid_vals_header; for my $val (@valid_values) { $line_length += length($val) + 1; # add 1 for space char my $default_line_length = $self->config->get( key => 'core.cli-line-length' ) || $self->cli->LINE_LENGTH; if ( $line_length > $default_line_length ) { $string .= "\n#"; $string .= q{ } x $valid_vals_header_len; $string .= $val; $line_length = $valid_vals_header_len + length($val); } else { $string .= " $val"; } } $string .= "\n"; } } $string .= "$prop: ".($args{data}->{$prop} ||'') ."\n"; } return $string; } =head2 parse_record_template $str Takes a string containing a ticket record consisting of prop: value pairs followed by a separator, followed by an optional comment. Returns a list of (hashref of prop => value pairs, string contents of comment) with props with false values filtered out. =cut sub parse_record_template { my $self = shift; my $ticket = shift; my @lines = split "\n", $ticket; my $last_seen_sep = ''; my %new_props; my $comment = ''; for my $line (@lines) { if ($line =~ $self->separator_pattern) { $last_seen_sep = $1; } elsif ($line =~ $self->comment_pattern) { # skip comments next; } elsif ( $last_seen_sep eq metadata_separator) { # skip unchangeable props next; } elsif ($last_seen_sep eq mutable_props_separator) { # match prop: value pairs. whitespace in between is ignored. if ($line =~ m/^([^:]+):\s*(.*)$/) { my $prop = $1; my $val = $2; $new_props{$prop} = $val unless !($val); } } elsif ($last_seen_sep eq comment_separator) { $comment .= $line . "\n"; } else { # Throw away the section } } return \%new_props, $comment; } no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Model/Attachment.pm0000644000175000017500000000022111552666431017370 0ustar spangspangpackage App::SD::CLI::Model::Attachment; use Any::Moose 'Role'; use constant record_class => 'App::SD::Model::Attachment'; no Any::Moose; 1; App-SD-0.75/lib/App/SD/CLI/Command.pm0000644000175000017500000000450011552666431015622 0ustar spangspangpackage App::SD::CLI::Command; use Any::Moose 'Role'; use Params::Validate qw(validate); =head2 get_content %args This is a helper routine for use in SD commands to enable getting records in different ways such as from a file, on the commandline, or from an editor. Returns the record content. Valid keys in %args are type => str, default_edit => bool, and prefill_props => $props_hash_ref, props_order => $order_array_ref, footer => str, header => str. Specifying props with prefill_props allows you to present lists of key/value pairs (with possible default values) for a user to fill in. If you need a specific ordering of props, specify it with C. Specifying C
and/or C