File Coverage

blib/lib/CTK/UtilXS.pm
Criterion Covered Total %
statement 47 54 87.0
branch 10 20 50.0
condition 5 12 41.6
subroutine 11 11 100.0
pod 2 2 100.0
total 75 99 75.7


line stmt bran cond sub pod time code
1             package CTK::UtilXS;
2 1     1   55440 use strict;
  1         7  
  1         23  
3 1     1   476 use utf8;
  1         11  
  1         4  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::UtilXS - CTK XS Utilities
10              
11             =head1 VERSION
12              
13             Version 1.01
14              
15             =head1 SYNOPSIS
16              
17             use CTK::UtilXS qw/shred wipe/;
18              
19             shred( "/path/to/file" ) or die("Can't shred file");
20             wipe( "/path/to/file" ) or die("Can't wipe file");
21              
22             =head1 DESCRIPTION
23              
24             CTK XS Utilities
25              
26             =head2 shred
27              
28             shred( "/path/to/file" ) or die("Can't shred file");
29              
30             Wipes file and remove it.
31              
32             Do a more secure overwrite of given files or devices, to make it harder for even very
33             expensive hardware probing to recover the data.
34              
35             =head2 wipe
36              
37             wipe( "/path/to/file" ) or die("Can't wipe file");
38              
39             Wipes file
40              
41             =head2 wipef, xstest, xsver
42              
43             Internal use only
44              
45             =head1 HISTORY
46              
47             See C file
48              
49             =head1 TO DO
50              
51             See C file
52              
53             =head1 BUGS
54              
55             * none noted
56              
57             =head1 SEE ALSO
58              
59             L
60              
61             =head1 AUTHOR
62              
63             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
64              
65             =head1 COPYRIGHT
66              
67             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
68              
69             =head1 LICENSE
70              
71             This program is free software; you can redistribute it and/or
72             modify it under the same terms as Perl itself.
73              
74             See C file and L
75              
76             =cut
77              
78 1     1   45 use vars qw($VERSION @EXPORT_OK);
  1         2  
  1         54  
79             $VERSION = '1.01';
80              
81 1     1   4 use base qw/ Exporter /;
  1         2  
  1         115  
82             @EXPORT_OK = qw/ xstest shred wipe /;
83              
84 1     1   6 use XSLoader;
  1         1  
  1         58  
85             XSLoader::load("CTK", $VERSION);
86              
87 1     1   5 use Carp;
  1         3  
  1         56  
88 1     1   365 use File::Spec::Functions qw/ splitpath catpath /;
  1         683  
  1         52  
89 1     1   397 use File::Copy qw/ move /;
  1         3716  
  1         375  
90              
91             sub wipe($) {
92 1   50 1 1 4 my $fn = shift // '';
93 1 50 33     24 my $sz = (length($fn) && -e $fn) ? (-s $fn) : 0;
94 1 50       4 return 0 unless $sz;
95 1 50       67 return 0 unless wipef($fn, $sz);
96 1         5 return 1;
97             }
98             sub shred($) {
99 1   50 1 1 4 my $fn = shift // '';
100 1 50 33     22 my $sz = (length($fn) && -e $fn) ? (-s $fn) : 0;
101 1 50       4 return 0 unless $sz;
102 1 50       67 return 0 unless wipef($fn, $sz);
103              
104 1         6 my ($vol,$dir,$file) = splitpath( $fn );
105              
106 1         18 my $nn = '';
107 1         3 for (my $i = 0; $i < 5; $i++) {
108 1         4 $nn = catpath($vol, $dir, sprintf("%s.%s", _sr(8), _sr(3)));
109 1 50       26 last unless -e $nn;
110 0         0 $nn = '';
111             }
112 1 50       4 unless ($nn) {
113 0         0 carp("Can't rename file \"$file\". Undefined new file");
114 0         0 return 0;
115             }
116              
117 1 50       4 move($fn, $nn) or do { carp("Can't move file \"$file\""); return 0; };
  0         0  
  0         0  
118 1 50       142 unlink($nn) or do { carp("Can't unlink file \"$nn\": $!"); return 0; };
  0         0  
  0         0  
119 1         6 return 1;
120             }
121             sub _sr {
122 2   50 2   4 my $l = shift || return '';
123 2         16 my @as = ('a'..'z','A'..'Z');
124 2         4 my $rst = '';
125 2         10 $rst .= $as[(int(rand($#as+1)))] for (1..$l);
126 2         13 return $rst;
127             }
128              
129             1;
130              
131             __END__