package VCP::Plugin ; =head1 NAME VCP::Plugin - A base class for VCP::Source and VCP::Dest =head1 SYNOPSIS use VCP::Plugin; @ISA = qw( VCP::Plugin ); ... =head1 DESCRIPTION Some functionality is common to sources and destinations, such as cache access, Pod::Usage conversion, command-line access shortcut member, etc. =head1 EXTERNAL METHODS =over =cut $VERSION = 0.1 ; use strict ; use File::Basename ; use File::Path qw( mkpath rmtree ); use File::Spec; use VCP::Logger qw( lg pr BUG ); use VCP::Revs; use VCP::Utils qw( is_win32 shell_quote xchdir start_dir ); #use fields ( # 'REVS', ## Any revisions we need to work with #); =item new Creates an instance, see subclasses for options. The options passed are usually native command-line options for the underlying repository's client. These are usually parsed and, perhaps, checked for validity by calling the underlying command line. =cut sub new { my $class = shift; return bless {}, $class; } =item plugin_documentation $paragraphs = $p->plugin_documentation; Returns POD documentation from the DESCRIPTION section of $self's .pm file. Use C to rewrap these. =cut sub plugin_documentation { my $self = shift; ## Parse from parent down to child so children can override parent's ## options documentation. require VCP::PodDESCRIPTIONParser; VCP::PodDESCRIPTIONParser->parse( ref $self ); } sub _reformat_docs_as_comments { my $self = shift; my $v = join "\n", "", map "$_\n", $self->wrap_pod_paragraphs( 60, @_ ); $v =~ s/^/ ## /mg; "$v\n"; } =item wrap_pod_paragraphs @paragraphs = VCP::Plugin->wrap_pod_paragraphs( $cols, @paragraphs ); Wraps non-verbatim POD text paragraphs to $cols. =cut sub wrap_pod_paragraphs { shift; require Text::Wrap; local $Text::Wrap::columns = shift; return map /^\s/ || /==\z/ ? "$_" : Text::Wrap::wrap( "", "", map split( /\n+/ ), $_ ), @_; } =back =cut ############################################################################### =head1 SUBCLASSING This class uses the fields pragma, so you'll need to use base and possibly fields in any subclasses. =head2 SUBCLASS API These methods are intended to support subclasses. =over =item init This is called after new() and before processing. No attempt to connect to or open a repository or database file should be made until init() is called (ie not in new()). =cut sub init { } =item usage_and_exit GetOptions( ... ) or $self->usage_and_exit ; Used by subclasses to die if unknown options are passed in. Requires Pod::Usage when called. =cut sub usage_and_exit { my $self = shift ; lg "options error emitted to STDERR for ", ref $self; require Pod::Usage ; my $f = ref $self ; $f =~ s{::}{/}g ; $f .= '.pm' ; for ( @INC ) { my $af = File::Spec->catfile( $_, $f ) ; if ( -f $af ) { Pod::Usage::pod2usage( -input => $af, -verbose => 0, -exitval => 2, ) ; BUG "pod2usage returned"; } } die "can't locate '$f' to print usage.\n" ; } =item tmp_dir Returns the temporary directory this plugin should use, usually something like "/tmp/vcp123/dest-p4". =cut my @END_subs; =item queue_END_sub In order to provide ordered destruction and cleanup at application shutdown, plugins can queue up code to run before all directories are deleted. =cut sub queue_END_sub { my $self = shift; BUG "more than one sub passed to queue_END_sub" if @_ > 1; my ( $sub ) = @_; BUG "non-CODE ref passed to queue_END_sub" if ref $sub ne "CODE"; push @END_subs, $sub; } sub cancel_END_sub { my $self = shift; BUG "more than one sub passed to cancel_END_sub" if @_ > 1; my ( $sub ) = @_; BUG "non-CODE ref passed to cancel_END_sub" if ref $sub ne "CODE"; @END_subs = grep $_ ne $sub, @_; } my %tmp_dirs ; END { return unless keys %tmp_dirs; xchdir "/" if is_win32; ## WinNT can't delete out from ## under cwd. for ( @END_subs ) { eval { $_->(); 1 } or pr "cleanup error: $@"; } rmtree [ reverse sort { length $a <=> length $b } keys %tmp_dirs ] if ! $ENV{VCPNODELETE} && %tmp_dirs ; } sub tmp_dir { my $self = shift ; my $plugin_dir = ref $self ; $plugin_dir =~ tr/A-Z/a-z/ ; $plugin_dir =~ s/^VCP:://i ; $plugin_dir =~ s/::/-/g ; my $tmp_dir_root = File::Spec->catdir( start_dir, "tmp", "vcp$$" ) ; ## Make sure no old tmpdir is there to mess us up in case ## a previous run crashed before cleanup or $ENV{VCPNODELETE} is set. if ( ! $tmp_dirs{$tmp_dir_root} && -e $tmp_dir_root ) { pr "removing previous working directory $tmp_dir_root"; rmtree [$tmp_dir_root ], 0; } $tmp_dirs{$tmp_dir_root} = 1 ; return File::Spec->catdir( $tmp_dir_root, $plugin_dir, @_ ) ; } =item mkdir $self->mkdir( $filename ) ; $self->mkdir( $filename, $mode ) ; Makes a directory and any necessary parent directories. The default mode is 770. Does some debug logging if any directories are created. Returns nothing. =cut sub mkdir { my $self = shift ; my ( $path, $mode ) = @_ ; BUG "undefined \$path" unless defined $path; BUG "empty \$path" unless length $path; $path =~ s{/+$}{}; ## Let *BSD and other POSIXly correct system work unless ( -d $path ) { $mode = 0770 unless defined $mode ; lg "\$ ", shell_quote "mkdir", sprintf( "--mode=%04o", $mode ), $path; eval { mkpath [ $path ], 0, $mode } or die "failed to create $path with mode $mode: $@\n" ; } return ; } =item mkpdir $self->mkpdir( $filename ) ; $self->mkpdir( $filename, $mode ) ; Makes the parent directory of a filename and all directories down to it. The default mode is 770. Does some debug logging if any directories are created. Returns the path of the parent directory. =cut sub mkpdir { my $self = shift ; my ( $path, $mode ) = @_ ; my ( undef, $dir ) = fileparse $path; $self->mkdir( $dir, $mode ) ; return $dir ; } =back =head1 COPYRIGHT Copyright 2000, Perforce Software, Inc. All Rights Reserved. This module and the VCP package are licensed according to the terms given in the file LICENSE accompanying this distribution, a copy of which is included in L. =head1 AUTHOR Barrie Slaymaker =cut 1