WebSVN – DevTools – Diff – /core_devl/trunk/TOOLS/LIB/JatsCopy.pm



#               Notify me if an existing file is present
#               Do not copy files called a2 and build.pl
#               Do not copy the .svn subdir
#               Do not copy files ending in 2
#
# Issues:
#               MatchDirs and MatchDirsRE don't work
#               Need to define what is wanted first
#               IgnoreDirs - appears to be useful
#
#......................................................................#
 
use strict;
use warnings;
 

#                       IgnoreDots      - True: Ignore files and dirs starting with .
#                       NoOverwrite     - True: Do not replace file in target
#                       DuplicateLinks  - True: Duplicate, don't copy links
#                       SymlinkFiles    - True: Create symlinks if possible
#                       ReadOnlyFiles   - True: Make files Read Only
#                       KeepSrcTail     - True: Keeps the tail of the source dir
#                     User callback functions
#                       Expert          - Function to do the work
#                       Examine         - Function to examine each entry
#                                         If True, then proceed
#                       Exists          - Function called if target file exists

#                       IgnoreRE        - An array of files to ignore (RE)
#                       IgnoreDirs      - An array of subdirs to ignore
#                       IgnoreDirsRE    - An array of subdirs to ignore (RE)
#                       Match           - An array of files to match
#                       MatchRE         - An array of file to match (RE)
#                       MatchDirs       - An array of dirs to match
#                       MatchDirsRE     - An array of dirs to match (RE)
#                     Misc
#                       Stats           - A ref to a hash of stats
#                       FileList        - Ref to array of target files
#                       UserData        - Item passed through to call backs
#                                         for the users own purposes.
#
#                   File and dir match/ignore operations come in two flavours
#                   Simple : Use of simple wildcards: ?,* and [...] constructs

    #
    $src_dir =~ s~/+$~~;
    $dst_dir =~ s~/+$~~;
 
    #
    #   Keep some fo the source directory
    #
    $dst_dir .= '/' . StripDir($src_dir)
        if ( $opt->{'KeepSrcTail'} );
 
    #
    #   Insert some default options
    #
    $opt->{'SrcDir'} = $src_dir;
    $opt->{'DstDir'} = $dst_dir;
 

    #
    #   Delete and create target dir
    #
    rmtree( $dst_dir )
        if ( $opt->{'DeleteFirst'} );
    JatsCopyInternal::CreateDir ( $dst_dir, $opt );
 
    #
    #   Invoke Find to decend the directory tree
    #
    #   Have used global vars to pass data into the find callback

# Inputs          : $src_file               - Src directory
#                   $dst_file               - Dest file (or dir)
#                   $opt                    - A Hash of options
#                                             Refer to CopyDir
#
# Returns         : Path to the target file
#
sub CopyFile
{
    my $src_file = shift;
    my $dst_file = shift;

    #   Do it within the copy operation and get the same error
    #   handling as the CopyDir processing
    #
 
    #
    #   If the target is a directory, then copy by name
    #
    my $file = StripDir ($src_file);
    $dst_file .= '/' . $file if ( -d $dst_file );
 
    #
    #   Insert additional options to provide the same interface to
    #   the internal functions used to do the copy
    #
    #       item            - Source Path
    #       tgt             - Dest subdir below dst_dir
    #       file            - Filename
    #       target          - Dest Path
    #
    $opt->{'item'}     = $src_file;
    $opt->{'file'}     = $file;
    $opt->{'target'}   = $dst_file;
    $opt->{'type'}     = 'f';
 
    #
    #   Invoke the common file copy routine
    #
    return JatsCopyInternal::CopyFile ( $src_file, $dst_file, $opt );
 
 
}
 
#-------------------------------------------------------------------------------
# Function        : CreateDir
#

{
    my $dst = shift;
    my $opt = JatsCopyInternal::DefaultOpts( 'CreateDir', @_ );
 
    #
 
 
 
 
 
 
    #   Insert additional options to provide the same interface to
    #   the internal functions used to do the copy
    #
    #       item            - Source Path
    #       tgt             - Dest subdir below dst_dir

    $opt->{'file'}     = '';
    $opt->{'target'}   = $dst;
    $opt->{'type'}     = 'd';
 
    #
    #   Delete and create target dir
    #
    if ( $opt->{'DeleteFirst'} && -e $dst )
    {
        $opt->{'Logger'} ( "Delete Dir" ,$opt );
        rmtree( $dst );
    }
    
    #
    #   Invoke the common file copy routine
    #
    JatsCopyInternal::CreateDir ( $dst, $opt );
 
#    DebugDumpData("opt", $opt );

    my ($dir, $opt) = @_;
    if ( ! -d $dir )
    {
        $opt->{'Logger'} ( "Creating Dir", $opt, $dir );
        mkpath($dir, 0, 0775);
        $opt->{'Error'} ( "Failed to create dir [$dir]: $!", $! , $opt )
            unless( -d $dir );
 
    }
}
 
#-------------------------------------------------------------------------------
# Function        : CopyFile

#
#
#                   Only a few of the options are implemented
#                   Becareful if using this function directly
#
# Returns         : The path of the target file
#
sub CopyFile
{
    my ($item, $target, $opt) = @_;
 

    #
    if ( -e $target )
    {
        if ( $opt->{'Exists'} )
        {
            return $target unless
                $opt->{'Exists'} ( $opt );
        }
        elsif ( $opt->{'NoOverwrite'} )
        {
            return $target;
        }
        rmtree( $target );
    }
 
    #

    #
    my $tdir = $target;
    $tdir =~ s~/[^/]+$~~;
    CreateDir ( $tdir, $opt);
 
    #
    #   If the target is a 'broken' link then we will have got this
    #   far. It wan't have been reported as existing
    #
    unlink $target
        if ( -l $target );
 
    #
    #   Save name of target file
    #
    if ( defined $opt->{'FileList'} )
    {
        push @{$opt->{'FileList'}}, $target;
    }
 
    {
        #
        #   Try a symlink first
        #
        if ( $opt->{'SymlinkFiles'}  )

        #
        #   All attempts to copy have failed
        #
        $opt->{'Error'} ( "Failed to copy file [$item] to [$target]: $!", $! ,$opt );
    }
 
    return $target;
}
 
 
#-------------------------------------------------------------------------------
# Function        : Log

    my %patmap = (
        '*' => '.*',
        '?' => '.',
        '[' => '[',
        ']' => ']',
        '-' => '-'
    );
    $globstr =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
    return '^' . $globstr . '$';
}
 

    } else {
        #
        #   A list of arguments
        #   Treat it as a hash. Must have an even number of arguments
        #
        Error ("$name: Odd number of args to function")
            unless ((@_ % 2) == 0);
        $uopt = {@_};
    }
 
    return $uopt;

    'IgnoreDirsRE'    => ArrayRef | Match,
    'NoOverwrite'     => Scalar,
    'UserData'        => 0,
    'SymlinkFiles'    => Scalar,
    'ReadOnlyFiles'   => Scalar,
    'KeepSrcTail'     => Scalar,
    'FileList'        => ArrayRef,
);
 
 
#-------------------------------------------------------------------------------
# Function        : ValidateArg

Rev 271	Rev 273
Line 49...	Line 49...
49	`# Notify me if an existing file is present`	49	`# Notify me if an existing file is present`
50	`# Do not copy files called a2 and build.pl`	50	`# Do not copy files called a2 and build.pl`
51	`# Do not copy the .svn subdir`	51	`# Do not copy the .svn subdir`
52	`# Do not copy files ending in 2`	52	`# Do not copy files ending in 2`
53	`#`	53	`#`
-		54	`# Issues:`
-		55	`# MatchDirs and MatchDirsRE don't work`
-		56	`# Need to define what is wanted first`
-		57	`# IgnoreDirs - appears to be useful`
-		58	`#`
54	`#......................................................................#`	59	`#......................................................................#`
55		60
56	`use strict;`	61	`use strict;`
57	`use warnings;`	62	`use warnings;`
58		63
Line 100...	Line 105...
100	`# IgnoreDots - True: Ignore files and dirs starting with .`	105	`# IgnoreDots - True: Ignore files and dirs starting with .`
101	`# NoOverwrite - True: Do not replace file in target`	106	`# NoOverwrite - True: Do not replace file in target`
102	`# DuplicateLinks - True: Duplicate, don't copy links`	107	`# DuplicateLinks - True: Duplicate, don't copy links`
103	`# SymlinkFiles - True: Create symlinks if possible`	108	`# SymlinkFiles - True: Create symlinks if possible`
104	`# ReadOnlyFiles - True: Make files Read Only`	109	`# ReadOnlyFiles - True: Make files Read Only`
-		110	`# KeepSrcTail - True: Keeps the tail of the source dir`
105	`# User callback functions`	111	`# User callback functions`
106	`# Expert - Function to do the work`	112	`# Expert - Function to do the work`
107	`# Examine - Function to examine each entry`	113	`# Examine - Function to examine each entry`
108	`# If True, then proceed`	114	`# If True, then proceed`
109	`# Exists - Function called if target file exists`	115	`# Exists - Function called if target file exists`
Line 115...	Line 121...
115	`# IgnoreRE - An array of files to ignore (RE)`	121	`# IgnoreRE - An array of files to ignore (RE)`
116	`# IgnoreDirs - An array of subdirs to ignore`	122	`# IgnoreDirs - An array of subdirs to ignore`
117	`# IgnoreDirsRE - An array of subdirs to ignore (RE)`	123	`# IgnoreDirsRE - An array of subdirs to ignore (RE)`
118	`# Match - An array of files to match`	124	`# Match - An array of files to match`
119	`# MatchRE - An array of file to match (RE)`	125	`# MatchRE - An array of file to match (RE)`
-		126	`# MatchDirs - An array of dirs to match`
-		127	`# MatchDirsRE - An array of dirs to match (RE)`
120	`# Misc`	128	`# Misc`
121	`# Stats - A ref to a hash of stats`	129	`# Stats - A ref to a hash of stats`
-		130	`# FileList - Ref to array of target files`
122	`# UserData - Item passed through to call backs`	131	`# UserData - Item passed through to call backs`
123	`# for the users own purposes.`	132	`# for the users own purposes.`
124	`#`	133	`#`
125	`# File and dir match/ignore operations come in two flavours`	134	`# File and dir match/ignore operations come in two flavours`
126	`# Simple : Use of simple wildcards: ?,* and [...] constructs`	135	`# Simple : Use of simple wildcards: ?,* and [...] constructs`
Line 156...	Line 165...
156	`#`	165	`#`
157	`$src_dir =~ s~/+$~~;`	166	`$src_dir =~ s~/+$~~;`
158	`$dst_dir =~ s~/+$~~;`	167	`$dst_dir =~ s~/+$~~;`
159		168
160	`#`	169	`#`
-		170	`# Keep some fo the source directory`
-		171	`#`
-		172	`$dst_dir .= '/' . StripDir($src_dir)`
-		173	`if ( $opt->{'KeepSrcTail'} );`
-		174
-		175	`#`
161	`# Insert some default options`	176	`# Insert some default options`
162	`#`	177	`#`
163	`$opt->{'SrcDir'} = $src_dir;`	178	`$opt->{'SrcDir'} = $src_dir;`
164	`$opt->{'DstDir'} = $dst_dir;`	179	`$opt->{'DstDir'} = $dst_dir;`
165		180
Line 183...	Line 198...
183	`#`	198	`#`
184	`# Delete and create target dir`	199	`# Delete and create target dir`
185	`#`	200	`#`
186	`rmtree( $dst_dir )`	201	`rmtree( $dst_dir )`
187	`if ( $opt->{'DeleteFirst'} );`	202	`if ( $opt->{'DeleteFirst'} );`
188	`mkpath($dst_dir, 0, 0775);`	203	`JatsCopyInternal::CreateDir ( $dst_dir, $opt );`
189		204
190	`#`	205	`#`
191	`# Invoke Find to decend the directory tree`	206	`# Invoke Find to decend the directory tree`
192	`#`	207	`#`
193	`# Have used global vars to pass data into the find callback`	208	`# Have used global vars to pass data into the find callback`
Line 214...	Line 229...
214	`# Inputs : $src_file - Src directory`	229	`# Inputs : $src_file - Src directory`
215	`# $dst_file - Dest file (or dir)`	230	`# $dst_file - Dest file (or dir)`
216	`# $opt - A Hash of options`	231	`# $opt - A Hash of options`
217	`# Refer to CopyDir`	232	`# Refer to CopyDir`
218	`#`	233	`#`
219	`# Returns :`	234	`# Returns : Path to the target file`
220	`#`	235	`#`
221	`sub CopyFile`	236	`sub CopyFile`
222	`{`	237	`{`
223	`my $src_file = shift;`	238	`my $src_file = shift;`
224	`my $dst_file = shift;`	239	`my $dst_file = shift;`
Line 229...	Line 244...
229	`# Do it within the copy operation and get the same error`	244	`# Do it within the copy operation and get the same error`
230	`# handling as the CopyDir processing`	245	`# handling as the CopyDir processing`
231	`#`	246	`#`
232		247
233	`#`	248	`#`
-		249	`# If the target is a directory, then copy by name`
-		250	`#`
-		251	`my $file = StripDir ($src_file);`
-		252	`$dst_file .= '/' . $file if ( -d $dst_file );`
-		253
-		254	`#`
234	`# Insert additional options to provide the same interface to`	255	`# Insert additional options to provide the same interface to`
235	`# the internal functions used to do the copy`	256	`# the internal functions used to do the copy`
236	`#`	257	`#`
237	`# item - Source Path`	258	`# item - Source Path`
238	`# tgt - Dest subdir below dst_dir`	259	`# tgt - Dest subdir below dst_dir`
239	`# file - Filename`	260	`# file - Filename`
240	`# target - Dest Path`	261	`# target - Dest Path`
241	`#`	262	`#`
242	`$opt->{'item'} = $src_file;`	263	`$opt->{'item'} = $src_file;`
243	`$opt->{'file'} = StripDir ($dst_file);`	264	`$opt->{'file'} = $file;`
244	`$opt->{'target'} = $dst_file;`	265	`$opt->{'target'} = $dst_file;`
245	`$opt->{'type'} = 'f';`	266	`$opt->{'type'} = 'f';`
246		267
247	`#`	268	`#`
248	`# Invoke the common file copy routine`	269	`# Invoke the common file copy routine`
249	`#`	270	`#`
250	`JatsCopyInternal::CopyFile ( $src_file, $dst_file, $opt );`	271	`return JatsCopyInternal::CopyFile ( $src_file, $dst_file, $opt );`
251		-
252	`# DebugDumpData("opt", $opt );`	-
253	`}`	272	`}`
254		273
255	`#-------------------------------------------------------------------------------`	274	`#-------------------------------------------------------------------------------`
256	`# Function : CreateDir`	275	`# Function : CreateDir`
257	`#`	276	`#`
Line 269...	Line 288...
269	`{`	288	`{`
270	`my $dst = shift;`	289	`my $dst = shift;`
271	`my $opt = JatsCopyInternal::DefaultOpts( 'CreateDir', @_ );`	290	`my $opt = JatsCopyInternal::DefaultOpts( 'CreateDir', @_ );`
272		291
273	`#`	292	`#`
274	`# Delete and create target dir`	-
275	`#`	-
276	`rmtree( $dst )`	-
277	`if ( $opt->{'DeleteFirst'} );`	-
278		-
279	`#`	-
280	`# Insert additional options to provide the same interface to`	293	`# Insert additional options to provide the same interface to`
281	`# the internal functions used to do the copy`	294	`# the internal functions used to do the copy`
282	`#`	295	`#`
283	`# item - Source Path`	296	`# item - Source Path`
284	`# tgt - Dest subdir below dst_dir`	297	`# tgt - Dest subdir below dst_dir`
Line 289...	Line 302...
289	`$opt->{'file'} = '';`	302	`$opt->{'file'} = '';`
290	`$opt->{'target'} = $dst;`	303	`$opt->{'target'} = $dst;`
291	`$opt->{'type'} = 'd';`	304	`$opt->{'type'} = 'd';`
292		305
293	`#`	306	`#`
-		307	`# Delete and create target dir`
-		308	`#`
-		309	`if ( $opt->{'DeleteFirst'} && -e $dst )`
-		310	`{`
-		311	`$opt->{'Logger'} ( "Delete Dir" ,$opt );`
-		312	`rmtree( $dst );`
-		313	`}`
-		314
-		315	`#`
294	`# Invoke the common file copy routine`	316	`# Invoke the common file copy routine`
295	`#`	317	`#`
296	`JatsCopyInternal::CreateDir ( $dst, $opt );`	318	`JatsCopyInternal::CreateDir ( $dst, $opt );`
297		319
298	`# DebugDumpData("opt", $opt );`	320	`# DebugDumpData("opt", $opt );`
Line 652...	Line 674...
652	`my ($dir, $opt) = @_;`	674	`my ($dir, $opt) = @_;`
653	`if ( ! -d $dir )`	675	`if ( ! -d $dir )`
654	`{`	676	`{`
655	`$opt->{'Logger'} ( "Creating Dir", $opt, $dir );`	677	`$opt->{'Logger'} ( "Creating Dir", $opt, $dir );`
656	`mkpath($dir, 0, 0775);`	678	`mkpath($dir, 0, 0775);`
-		679	`$opt->{'Error'} ( "Failed to create dir [$dir]: $!", $! , $opt )`
-		680	`unless( -d $dir );`
-		681
657	`}`	682	`}`
658	`}`	683	`}`
659		684
660	`#-------------------------------------------------------------------------------`	685	`#-------------------------------------------------------------------------------`
661	`# Function : CopyFile`	686	`# Function : CopyFile`
Line 668...	Line 693...
668	`#`	693	`#`
669	`#`	694	`#`
670	`# Only a few of the options are implemented`	695	`# Only a few of the options are implemented`
671	`# Becareful if using this function directly`	696	`# Becareful if using this function directly`
672	`#`	697	`#`
673	`# Returns : Nothing`	698	`# Returns : The path of the target file`
674	`#`	699	`#`
675	`sub CopyFile`	700	`sub CopyFile`
676	`{`	701	`{`
677	`my ($item, $target, $opt) = @_;`	702	`my ($item, $target, $opt) = @_;`
678		703
Line 682...	Line 707...
682	`#`	707	`#`
683	`if ( -e $target )`	708	`if ( -e $target )`
684	`{`	709	`{`
685	`if ( $opt->{'Exists'} )`	710	`if ( $opt->{'Exists'} )`
686	`{`	711	`{`
687	`return unless`	712	`return $target unless`
688	`$opt->{'Exists'} ( $opt );`	713	`$opt->{'Exists'} ( $opt );`
689	`}`	714	`}`
690	`elsif ( $opt->{'NoOverwrite'} )`	715	`elsif ( $opt->{'NoOverwrite'} )`
691	`{`	716	`{`
692	`return;`	717	`return $target;`
693	`}`	718	`}`
694	`rmtree( $target );`	719	`rmtree( $target );`
695	`}`	720	`}`
696		721
697	`#`	722	`#`
Line 700...	Line 725...
700	`#`	725	`#`
701	`my $tdir = $target;`	726	`my $tdir = $target;`
702	`$tdir =~ s~/[^/]+$~~;`	727	`$tdir =~ s~/[^/]+$~~;`
703	`CreateDir ( $tdir, $opt);`	728	`CreateDir ( $tdir, $opt);`
704		729
-		730	`#`
-		731	`# If the target is a 'broken' link then we will have got this`
-		732	`# far. It wan't have been reported as existing`
-		733	`#`
-		734	`unlink $target`
-		735	`if ( -l $target );`
-		736
-		737	`#`
-		738	`# Save name of target file`
-		739	`#`
-		740	`if ( defined $opt->{'FileList'} )`
-		741	`{`
-		742	`push @{$opt->{'FileList'}}, $target;`
-		743	`}`
-		744
705	`{`	745	`{`
706	`#`	746	`#`
707	`# Try a symlink first`	747	`# Try a symlink first`
708	`#`	748	`#`
709	`if ( $opt->{'SymlinkFiles'} )`	749	`if ( $opt->{'SymlinkFiles'} )`
Line 754...	Line 794...
754	`#`	794	`#`
755	`# All attempts to copy have failed`	795	`# All attempts to copy have failed`
756	`#`	796	`#`
757	`$opt->{'Error'} ( "Failed to copy file [$item] to [$target]: $!", $! ,$opt );`	797	`$opt->{'Error'} ( "Failed to copy file [$item] to [$target]: $!", $! ,$opt );`
758	`}`	798	`}`
-		799
-		800	`return $target;`
759	`}`	801	`}`
760		802
761		803
762	`#-------------------------------------------------------------------------------`	804	`#-------------------------------------------------------------------------------`
763	`# Function : Log`	805	`# Function : Log`
Line 851...	Line 893...
851	`my %patmap = (`	893	`my %patmap = (`
852	`'' => '.',`	894	`'' => '.',`
853	`'?' => '.',`	895	`'?' => '.',`
854	`'[' => '[',`	896	`'[' => '[',`
855	`']' => ']',`	897	`']' => ']',`
-		898	`'-' => '-'`
856	`);`	899	`);`
857	`$globstr =~ s{(.)} { $patmap{$1} \|\| "\Q$1" }ge;`	900	`$globstr =~ s{(.)} { $patmap{$1} \|\| "\Q$1" }ge;`
858	`return '^' . $globstr . '$';`	901	`return '^' . $globstr . '$';`
859	`}`	902	`}`
860		903
Line 993...	Line 1036...
993	`} else {`	1036	`} else {`
994	`#`	1037	`#`
995	`# A list of arguments`	1038	`# A list of arguments`
996	`# Treat it as a hash. Must have an even number of arguments`	1039	`# Treat it as a hash. Must have an even number of arguments`
997	`#`	1040	`#`
998	`Error ("$name: Odd number of args to SvnRmView")`	1041	`Error ("$name: Odd number of args to function")`
999	`unless ((@_ % 2) == 0);`	1042	`unless ((@_ % 2) == 0);`
1000	`$uopt = {@_};`	1043	`$uopt = {@_};`
1001	`}`	1044	`}`
1002		1045
1003	`return $uopt;`	1046	`return $uopt;`
Line 1040...	Line 1083...
1040	`'IgnoreDirsRE' => ArrayRef \| Match,`	1083	`'IgnoreDirsRE' => ArrayRef \| Match,`
1041	`'NoOverwrite' => Scalar,`	1084	`'NoOverwrite' => Scalar,`
1042	`'UserData' => 0,`	1085	`'UserData' => 0,`
1043	`'SymlinkFiles' => Scalar,`	1086	`'SymlinkFiles' => Scalar,`
1044	`'ReadOnlyFiles' => Scalar,`	1087	`'ReadOnlyFiles' => Scalar,`
-		1088	`'KeepSrcTail' => Scalar,`
-		1089	`'FileList' => ArrayRef,`
1045	`);`	1090	`);`
1046		1091
1047		1092
1048	`#-------------------------------------------------------------------------------`	1093	`#-------------------------------------------------------------------------------`
1049	`# Function : ValidateArg`	1094	`# Function : ValidateArg`

Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/LIB/JatsCopy.pm – Rev 271 → 273