Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

Bulk file attachment extractor for Lotus Domino

by diotalevi (Canon)
on Oct 14, 2004 at 19:44 UTC ( [id://399311]=sourcecode: print w/replies, xml ) Need Help??
Category: Utility Scripts
Author/Contact Info
Description: A simple extraction tool for Lotus Domino applications.
use strict;
use warnings;
use Notes::OLE;
use AppConfig::Std ();
use File::Spec ();
use Memoize 'memoize';
use vars qw( $CONFIG $VERSION );

$VERSION = 0.01;

main( @ARGV );
exit 0;

sub main {

  initialize( @_ );
  
  my $db = $S->GetDatabase( $CONFIG->server, $CONFIG->filepath );
  defined( $db ) and
    $db->IsOpen or
      die "Couldn't open '" . $CONFIG->server . "', '" . $CONFIG->file
+path . "'\n";
  
  my $dc = $db->Search( $CONFIG->query,
            $S->CreateDateTime( $CONFIG->since ),
            0 );
  
  dc_all( $dc, \ &extract_attachments );
  
  glob File::Spec->catfile( $CONFIG->directory,
                "*" );
  
  1;
}

sub extract_attachments {
  my $doc = shift;
  
  my $dt = $doc->Created;
  my $date = $dt->Date( 'yyyyMMdd' );
  my $time = $dt->Time( 'HHmmss' );
  my $timestamp = "$date$time";
  
  for my $attachment_name ( @{$doc->{'$FILE'}} ) {
    ( my $group_name = $attachment_name )
      =~ s/\.[^.]+$//;

    my $dir = File::Spec->catdir( $CONFIG->directory,
                  $group_name );
    recursive_mkdir( $dir );
    my $filename = File::Spec->catfile( $dir,
                    "$timestamp-$attachment_name" );
    if ( -e $filename ) {
      warn "$timestamp version of $attachment_name already exists.\n";
    }
    else {
      my $att = $doc->GetAttachment( $attachment_name );
      $att->ExtractFile( $filename );
    }
  }
  
  1;
}

sub initialize {
  $| = 1;
  
  $CONFIG = AppConfig::Std->new;
  $CONFIG->define( server =>
           { DEFAULT => '',
             ALIAS => "s" } );
  $CONFIG->define( filepath =>
           { ALIAS => 'f' } );
  $CONFIG->define( query =>
           { ALIAS => 'q|search|formula',
             DEFAULT => '@ALL' } );
  $CONFIG->define( since =>
           { DEFAULT => '' } );
  $CONFIG->define( directory =>
           { DEFAULT => ".",
             ALIAS => "d|dir" } );
  $CONFIG->args( \ @_ );
  
  $CONFIG->filepath
    or die "-filepath is required.\n";
  
  if ( not length $CONFIG->directory ) {
      $CONFIG->directory( "." );
  }

  recursive_mkdir( $CONFIG->directory );

  # Only produce results with attachments.
  $CONFIG->query( '@Attachments( 1 )'
          . ( length( $CONFIG->query )
              ? ( ' & (' . $CONFIG->query . ')' )
              : '' ) );

  1;
}

sub recursive_mkdir {
  my $dir = shift;
  my @dir_parts = File::Spec->splitdir( $dir );
  for ( 1 .. @dir_parts )
  {
      my $cur_dir = File::Spec->catdir( @dir_parts[ map $_ - 1,
                            1 .. $_ ] );
      if ( not -d $cur_dir ) {
    mkdir $cur_dir
      or die "Couldn't create $cur_dir: $!\n";
      }
  }
  1;
}
BEGIN { memoize 'recursive_mkdir' };

__END__

=pod

=head1 NAME

ExtractAttachments - Extract attachments from selected documents in a 
+Domino database

=head1 SYNOPSIS

ExtractAttachments -filepath MyDb -since Yesterday -dir C:\Templates -
+query "@Name([CN];Author) = @Name([CN];@Username)"

=head1 DESCRIPTION

This detaches attachments from documents.

=head1 OPTIONS

=over 4

=item -s SERVER

=item -f FILEPATH

=item -q FORMULA

=item -since DATETIME

=item -d DIRECTORY

=back

=cut

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://399311]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others imbibing at the Monastery: (5)
As of 2024-03-28 16:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found