Pm/Bc_dir.pm
Copying Source is Forbidden
497 lines of code
1
package Bc_dir;
2
3
#/
4
# a module for listing directories and files
5
#
6
# <table border=0 cellpadding=0 cellspacing=0 width=100%><tr><td align=center><table class=error cellpadding=0 cellspacing=0><tr><td align=center>This is base code<hr style='background-image: none; background-color: #FF0000; width: 50%;'></td></tr><tr><td align=center><b>do not</b> include any use statements like<br><i>use Pm::Bc_chef</i></td></tr></table></td></tr></table>
7
#/
8
9
use strict;
10
use warnings;
11
use CGI::Carp qw(fatalsToBrowser);
12
use Exporter;
13
use vars qw($VERSION @ISA @EXPORT_OK @EXPORT);
14
15
$VERSION = 1.00;
16
@ISA = qw(Exporter);
17
@EXPORT = qw(
18
$dot
19
$dotdot
20
);
21
@EXPORT_OK = qw(
22
_tests
23
24
dirs
25
files
26
files_asHash
27
external_dirs
28
external_files
29
file_exists
30
folder_exists
31
del_file
32
move_file
33
rename_file
34
make_dir
35
remove_dir
36
images
37
read_text
38
write_text
39
lineCount
40
read_text_asArray
41
42
$dot
43
$dotdot
44
);
45
46
##############################
47
our $dot = ".";
48
our $dotdot = "..";
49
##############################
50
51
##############################
52
sub dirs($) {
53
#*
54
# gets a list of folders in a specified folder
55
# can be empty if the folder doesn't exist or has no folders
56
# do not include leading or trailing /'s
57
#*
58
my ($folder) = @_; # a folder relative to web root
59
if ($folder) { $folder = "/$folder"; }
60
61
# the next few lines ensure we list files from webroot (and its subdirs) only
62
$folder =~ s/^(\/)*//; # remove any leading /'s
63
$folder =~ s/(\/)*$//; # remove any trailing /'s
64
$folder =~ s/\.|\.\.//; # remove any . or ..
65
$folder =~ s/\/\//\//g; # convert // to /
66
$folder = "/Apache24/htdocs/$folder/*";
67
$folder =~ s/\/\//\//g; # convert // to / - again? yes - just in case $folder eq ""
68
69
my @directories = grep {-d} glob($folder);
70
foreach my $dir (@directories) { $dir =~ s/(.)*\///; } # remove path, preserve filename only
71
72
return @directories; # a list of folders
73
#usage: my @folders = dirs("users");
74
}
75
76
##############################
77
sub files($;$) {
78
#*
79
# lists files within a specified folder (eg: config, images)
80
# folders should not be included in this list
81
# if no type is provided, *.* is assumed
82
#*
83
# do not include leading or trailing /'s
84
my ($folder, $type) = @_; # a folder relative to web root && a file type (optional)
85
86
if ($type) {
87
$type =~ s/(\*)*//g; # remove stars
88
$type =~ s/(\.)*//; # remove dots
89
$type =~ s/\///g; # remove forward slashes
90
if ($type) { $type = ".$type"; }
91
} else {
92
$type = "";
93
}
94
95
if ($folder) {
96
$folder =~ s/^(\/)*//; # remove any leading /'s
97
$folder =~ s/(\/)*$//; # remove any trailing /'s
98
$folder =~ s/\.|\.\.//g; # remove any . or ..
99
$folder =~ s/\/\//\//g; # convert // to /
100
$folder = "/var/www/html/$folder/*";
101
$folder =~ s/\/\//\//g; # convert // to / - again? yes - just in case $folder eq ""
102
}
103
104
my $filespec = $folder . $type;
105
106
my @list = grep {-f} glob($filespec);
107
#push @list, $filespec;
108
foreach my $f (@list) { $f =~ s/(.)*\///; }
109
110
return @list; # a a list of files
111
#usage: my @fileList = files("config", "txt");
112
}
113
114
##############################
115
sub files_asHash($;$) {
116
#*
117
# lists files (as a hash) within a specified folder (eg: config, txt)
118
# folders will not be included in this list
119
# if no type is provided, *.* is assumed
120
#*
121
# the next few lines ensure we list files from webroot (and its subdirs) only
122
# do not include leading or trailing /'s
123
my ($folder, $type) = @_; # a folder relative to web root && a file type (optional)
124
125
if ($type) {
126
$type =~ s/(\*)*//g; # remove stars
127
$type =~ s/(\.)*//; # remove dots
128
$type =~ s/\///g; # remove forward slashes
129
if ($type) { $type = ".$type"; }
130
} else { $type = ""; }
131
132
if ($folder) {
133
$folder =~ s/^(\/)*//; # remove any leading /'s
134
$folder =~ s/(\/)*$//; # remove any trailing /'s
135
$folder =~ s/\.|\.\.//g; # remove any . or ..
136
$folder =~ s/\/\//\//g; # convert // to /
137
$folder = "/var/www/html/$folder/*";
138
$folder =~ s/\/\//\//g; # convert // to / - again? yes - just in case $folder eq ""
139
}
140
141
my $filespec = $folder . "*" . $type;
142
143
my @list = grep {-f} glob($filespec);
144
#push @list, $filespec;
145
foreach my $f (@list) { $f =~ s/(.)*\///; }
146
147
# convert list to a hash!
148
my %hash;
149
foreach my $file (@list) {
150
$hash{$file} = 1;
151
}
152
153
return %hash; # a hashed list of files ($hash{"file.txt"} = 1)
154
#usage: my @fileList = files("config", "txt");
155
}
156
157
##############################
158
sub file_exists($) {
159
#*
160
# determines if a file exists or not
161
# do not include leading or trailing /'s
162
#*
163
my ($fn) = @_; # a file name, with folder relative to web root
164
my $rv = 0;
165
if (-e $fn) {
166
$rv = 1; # 1 if file exists
167
}
168
169
return $rv; # 0 if file does not exist, or 1 if it exists
170
#usage: my $fe = file_exists("users/123abc/stats.txt");
171
}
172
173
##############################
174
sub folder_exists($) {
175
#*
176
# determines if a folder exists or not
177
# do not include leading or trailing /'s
178
#*
179
my ($folder) = @_; # a folder relative to web root
180
if (-e $folder) {
181
return 1; # 1 if the folder exists
182
}
183
184
return 0; # 0 if folder does not exist
185
#usage: my $fe = folder_exists("users/123abc");
186
}
187
188
##############################
189
sub del_file($) {
190
#*
191
# deletes the specified file
192
# !be warned: can delete any file!
193
#*
194
my ($file) = @_; # the file to delete (including folder), relative to web root
195
196
return unlink $file; # the number of files deleted
197
#usage: my $f = del_file("users/123abc/stats.txt");
198
}
199
200
##############################
201
sub move_file($$) {
202
#*
203
# moves a file (can rename file)
204
# this function is not yet complete!
205
# do not include leading or trailing /'s
206
#*
207
my ($old, $new) = @_; # old file name && new file name
208
209
use File::Copy qw(move);
210
move $old, $new;
211
212
return 0; # 0 on failure
213
#usage: my $mr = move_file("bob.txt", "users/bob/bob.txt")
214
}
215
216
##############################
217
sub rename_file($$) {
218
#*
219
# renames a file
220
# this function is not yet complete!
221
# do not include leading or trailing /'s
222
#*
223
my ($old, $new) = @_; # the old file name, relative to web root && the new file name, relative to web root
224
225
return 0; # 0 on failure
226
#usage if (rename_file('users/bob.txt', 'users/bobby.txt')) { print "file renamed"; }
227
}
228
229
##############################
230
sub make_dir($$) {
231
#*
232
# creates a directory in a specified location
233
# this function is not yet complete!
234
# do not include leading or trailing /'s
235
#*
236
my ($indir, $newdir) = @_; # location to make directory, relative to web root && name of new directory, relative to $indir
237
238
return 0; # 0 on failure
239
#usage: if (make_dir("users", "bob")) { print "folder created"; }
240
}
241
242
##############################
243
sub remove_dir($) {
244
#*
245
# deletes a folder
246
# USE WITH CAUTION!
247
#*
248
my ($folder) = @_; # location of folder to obliterate, relative to web root
249
250
return rmtree $folder; # the number of folders deleted
251
#usage: if (remove_dir("bob")) { print "folder obliterated"; }
252
}
253
254
##############################
255
sub external_dirs($) {
256
#*
257
# gets a list of folders in a specified folder
258
# this doesn't seem to like "spaces" in $loc
259
# how to fix it...
260
#*
261
my ($loc) = @_; # a location (eg: /entertainment/Downloads)
262
my @dirs = glob("\"$loc" . "/*" . "\"");
263
my @fixed;
264
foreach my $dir (@dirs) {
265
if (-d $dir) {
266
$dir =~ s/$loc\///;
267
push (@fixed, $dir);
268
}
269
}
270
271
return @fixed; # an array
272
#usage: dirs("users");
273
}
274
275
##############################
276
sub external_files($$) {
277
#*
278
# lists files within a specified folder (eg: config, txt)
279
# folders should not be included in this list
280
# if no type is provided, *.* is assumed
281
#*
282
my ($folder, $type) = @_; # a location (eg: users), relative to web root
283
if ($type) {
284
$type =~ s/(\*)*//g; # remove stars
285
$type =~ s/(\.)*//; # remove dots
286
$type =~ s/\///g; # remove forward slashes
287
if ($type) { $type = ".$type"; }
288
}
289
290
if ($folder) {
291
$folder =~ s/(\/)*$//; # remove trailing /'s
292
#$folder =~ s/^(\/)*//; # remove leading /'s
293
$folder =~ s/\/\//\//g; # convert //'s to /
294
$folder .= "/"; # attach trailing /
295
}
296
297
my @fixed;
298
my $filespec = $folder . "*" . $type;
299
#push @fixed, $filespec;
300
301
my @dirs = glob("\"$filespec\"");
302
$folder =~ s/\./\\./g;
303
$folder =~ s/\//\\\//g;
304
foreach my $dir (@dirs) {
305
if (-f $dir) {
306
$dir =~ s/$folder//;
307
push (@fixed, $dir);
308
}
309
}
310
311
return @fixed; # an array
312
#usage: my @fileList = external_files("/data/Downloads", "exe");
313
}
314
315
##############################
316
sub images($) {
317
#*
318
# lists images within a specified folder (eg: config, txt)
319
# folders should not be included in this list
320
#*
321
my ($loc) = @_; # a folder to list images from, relative to web root
322
323
my @bmps = files($loc, "bmp");
324
my @gifs = files($loc, "gif");
325
my @pngs = files($loc, "png");
326
my @jpgs = files($loc, "jpg");
327
my @jpegs = files($loc, "jpeg");
328
my @icos = files($loc, "ico");
329
my @imgs = @bmps;
330
push @imgs, @gifs;
331
push @imgs, @pngs;
332
push @imgs, @jpgs;
333
push @imgs, @jpegs;
334
push @imgs, @icos;
335
336
return @imgs; # a list of just images
337
#usage: my @imgList = images("/");
338
}
339
340
##############################
341
sub lineCount($) {
342
#*
343
# returns the number of lines and a
344
# character count in a hash.
345
# keys are {lines} and {chars}
346
#*
347
my ($f) = @_; # a filename relative to web root
348
my $data = read_text($f);
349
350
# let's remove only any TRAILING \n's from $data!
351
# so's not to artifically inflate the counts
352
$data =~ s/\n$//a;
353
354
my @lines = split("\n", $data);
355
my %counts;
356
357
$counts{lines} = @lines;
358
$counts{chars} = length $data;
359
360
return %counts; # a hash with two numbers (line and char counts)
361
#usage: my %counts = lineCount("index.pl");
362
}
363
364
##############################
365
sub read_text($) {
366
#*
367
# reads a file into a <b>\n</b> separated scalar
368
#*
369
my ($fn) = @_; # the file to read (eg users/bob.txt)
370
my $rv = 0;
371
372
if (open my $F, "<", "$fn") {
373
local $/;
374
my $data = <$F>; # should slurp up the entire file
375
close $F;
376
377
$data =~ s/(\n)*$//;
378
$data =~ s/^(\n)*//;
379
$rv = $data; # a scalar representing file data
380
} else {
381
$rv = "$!: $fn"; # error when no data (includes error desc)
382
#die "$!: $fn";
383
}
384
385
return $rv; # the data on success, or 0 on failure
386
#usage: my $data = read_text($fn);
387
}
388
389
##############################
390
sub write_text($$;$) {
391
#*
392
# writes a scalar to a file
393
#*
394
my ($fn, $data, $append) = @_; # the file to read (eg users/bob.txt) && the data to write to the file && append data to $fn
395
my $rv = 1;
396
my $write_type = ">";
397
if ($append) { $write_type = ">>"; }
398
$data =~ s/\r//g;
399
400
if (open my $F, $write_type, "$fn") {
401
local $/;
402
print $F $data;
403
close $F;
404
405
$rv = 0; # 0 on success (yes, zero!)
406
} else {
407
$rv = "$!"; # error when no data given (includes error desc)
408
}
409
410
return $rv; # 0 on success, or error msg otherwise
411
#usage: my $data = read_text($fn);
412
}
413
414
##########################
415
sub read_text_asArray($) {
416
#*
417
# reads a text file, line by line.
418
# each line is plugged into an array
419
# ALWAYS returns an array
420
#*
421
my ($fn) = @_; # file name to read
422
423
my $FH;
424
my @lines = ();
425
426
if (open $FH, "<", "$fn") {
427
while (my $line = <$FH>) {
428
chomp $line;
429
push @lines, $line;
430
}
431
432
close $FH;
433
}
434
435
return @lines; # an array of lines of data in specified file
436
#usage: my @data = read_text_asArray($filename);
437
}
438
439
##############################
440
sub _tests(;$) {
441
#*
442
# to test all <i>Pm::Bc_dir</i> functions
443
#*
444
my ($extended) = @_; # show extended data (optional)
445
my $rv = "";
446
my $test = 0;
447
my $test2 = 0;
448
my $test3 = 0;
449
my @test = ();
450
451
if ($Bc_sql::DB) {
452
$rv .= Html::display_debug_one("del_file(...)", "test skipped");
453
$test = "../";
454
@test = dirs($test);
455
$rv .= Html::display_debug_many("dirs(\"$test\") <small>this should fail</small>", \@test, ", ");
456
@test = external_dirs($test);
457
$rv .= Html::display_debug_many("external_dirs(\"$test\")", \@test, ", ");
458
$test2 = "*.txt";
459
@test = external_files($test, $test2);
460
$rv .= Html::display_debug_many("external_files(\"$test\", \"$test2\")", \@test, ", ");
461
$test3 = "/entertainment/Downloads/test1.mp4";
462
$rv .= Html::display_debug_one("file_exists(\"$test3\")", file_exists($test3));
463
$test = "Pm";
464
$test2 = "pm";
465
@test = files($test, $test2);
466
$rv .= Html::display_debug_many("files(\"$test\", \"$test2\")", \@test, ", ");
467
$rv .= Html::display_debug_one("folder_exists(\"$test\")", folder_exists($test));
468
$test = "images/site";
469
@test = images($test);
470
$rv .= Html::display_debug_many("images(\"$test\")", \@test, ", ");
471
$rv .= Html::display_debug_one("make_dir(...)", "test skipped");
472
$rv .= Html::display_debug_one("move_file(...)", "test skipped");
473
$rv .= Html::display_debug_one("remove_dir(...)", "test skipped");
474
$rv .= Html::display_debug_one("rename_file(...)", "test skipped");
475
476
my %counts = lineCount("index.pl");
477
$rv .= Html::display_debug_many("lineCount('index.pl')", \%counts, "<br>");
478
479
Bc_sql::sql_disconnect();
480
# end if ($DB)
481
} else {
482
$rv .= "DB connection error!<br>\n";
483
# end else of if ($DB)
484
}
485
486
return $rv; # 0 on failure, or a scalar
487
#usage: print _tests(1);
488
}
489
490
##############################
491
##############################
492
##############################
493
##############################
494
##############################
495
##############################
496
497
1;