[system] / branches / gage_dev / webwork2 / lib / WeBWorK / Utils.pm Repository:
ViewVC logotype

Diff of /branches/gage_dev/webwork2/lib/WeBWorK/Utils.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 410 Revision 2891
1################################################################################
2# WeBWorK Online Homework Delivery System
3# Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/
4# $CVSHeader: webwork-modperl/lib/WeBWorK/Utils.pm,v 1.56 2004/10/07 23:08:13 gage Exp $
5#
6# This program is free software; you can redistribute it and/or modify it under
7# the terms of either: (a) the GNU General Public License as published by the
8# Free Software Foundation; either version 2, or (at your option) any later
9# version, or (b) the "Artistic License" which comes with this package.
10#
11# This program is distributed in the hope that it will be useful, but WITHOUT
12# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
13# FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the
14# Artistic License for more details.
15################################################################################
16
1package WeBWorK::Utils; 17package WeBWorK::Utils;
2
3use base qw(Exporter); 18use base qw(Exporter);
4 19
20=head1 NAME
21
22WeBWorK::Utils - useful utilities used by other WeBWorK modules.
23
24=cut
25
26use strict;
27use warnings;
28#use Apache::DB;
29use DateTime;
30use Date::Parse;
31use Date::Format;
32use Time::Zone;
33#use Date::Manip;
34#use DateTime::Format::DateManip;
35use Errno;
36use File::Path qw(rmtree);
37use Carp;
38
39use constant MKDIR_ATTEMPTS => 10;
40
41# "standard" WeBWorK date/time format (for set definition files):
42# %m/%d/%y at %I:%M%P
43# where:
44# %m = month number, starting with 01
45# %d = numeric day of the month, with leading zeros (eg 01..31)
46# %Y = year (4 digits)
47# %I = hour, 12 hour clock, leading 0's)
48# %M = minute, leading 0's
49# %P = am or pm (Yes %p and %P are backwards :)
50use constant DATE_FORMAT => "%m/%d/%Y at %I:%M%P %Z";
51
5our @EXPORT = (); 52our @EXPORT = ();
6our @EXPORT_OK = qw(runtime_use readFile); 53our @EXPORT_OK = qw(
54 runtime_use
55 readFile
56 readDirectory
57 listFilesRecursive
58 surePathToFile
59 makeTempDirectory
60 removeTempDirectory
61 formatDateTime
62 parseDateTime
63 textDateTime
64 intDateTime
65 writeLog
66 writeCourseLog
67 writeTimingLogEntry
68 list2hash
69 ref2string
70 decodeAnswers
71 encodeAnswers
72 max
73 pretty_print_rh
74 cryptPassword
75 dequote
76 undefstr
77 sortByName
78);
79
80################################################################################
81# Lowlevel thingies
82################################################################################
7 83
8sub runtime_use($) { 84sub runtime_use($) {
9 return unless @_; 85 croak "runtime_use: no module specified" unless $_[0];
10 eval "require $_[0]; import $_[0]"; 86 eval "package Main; require $_[0]; import $_[0]";
11 die $@ if $@; 87 die $@ if $@;
88}
89
90#sub backtrace($) {
91# my ($style) = @_;
92# $style = "warn" unless $style;
93# my @bt = DB->backtrace;
94# shift @bt; # Remove "backtrace" from the backtrace;
95# if ($style eq "die") {
96# die join "\n", @bt;
97# } elsif ($style eq "warn") {
98# warn join "\n", @bt;
99# } elsif ($style eq "print") {
100# print join "\n", @bt;
101# } elsif ($style eq "return") {
102# return @bt;
103# }
104#}
105
106################################################################################
107# Filesystem interaction
108################################################################################
109
110# Convert Windows and Mac (classic) line endings to UNIX line endings in a string.
111# Windows uses CRLF, Mac uses CR, UNIX uses LF. (CR is ASCII 15, LF if ASCII 12)
112sub force_eoln($) {
113 my ($string) = @_;
114 $string =~ s/\015\012?/\012/g;
115 return $string;
12} 116}
13 117
14sub readFile($) { 118sub readFile($) {
15 my $fileName = shift; 119 my $fileName = shift;
16 open INPUTFILE, "<", $fileName 120 local $/ = undef; # slurp the whole thing into one string
121 open my $dh, "<", $fileName
17 or die "Failed to read $fileName: $!"; 122 or die "failed to read file $fileName: $!";
18 local $/ = undef; 123 my $result = <$dh>;
19 my $result = <INPUTFILE>; 124 close $dh;
20 close INPUTFILE; 125 return force_eoln($result);
126}
127
128sub readDirectory($) {
129 my $dirName = shift;
130 opendir my $dh, $dirName
131 or die "Failed to read directory $dirName: $!";
132 my @result = readdir $dh;
133 close $dh;
21 return $result; 134 return @result;
22} 135}
136
137=item @matches = listFilesRecusive($dir, $match_qr, $prune_qr, $match_full, $prune_full)
138
139Traverses the directory tree rooted at $dir, returning a list of files, named
140pipes, and sockets matching the regular expression $match_qr. Directories
141matching the regular expression $prune_qr are not visited.
142
143$match_full and $prune_full are boolean values that indicate whether $match_qr
144and $prune_qr, respectively, should be applied to the bare directory entry
145(false) or to the path to the directory entry relative to $dir.
146
147@matches is a list of paths relative to $dir.
148
149=cut
150
151sub listFilesRecursiveHelper($$$$$$);
152sub listFilesRecursive($;$$$$) {
153 my ($dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_;
154 return listFilesRecursiveHelper($dir, "", $match_qr, $prune_qr, $match_full, $prune_full);
155}
156
157sub listFilesRecursiveHelper($$$$$$) {
158 my ($base_dir, $curr_dir, $match_qr, $prune_qr, $match_full, $prune_full) = @_;
159
160 my $full_dir = "$base_dir/$curr_dir";
161
162 my @dir_contents = readDirectory($full_dir);
163
164 my @matches;
165
166 foreach my $dir_entry (@dir_contents) {
167 my $full_path = "$full_dir/$dir_entry";
168 if (-d $full_path or -l $full_path) {
169 # standard things to skip
170 next if $dir_entry eq ".";
171 next if $dir_entry eq "..";
172
173 # skip unreadable directories (and broken symlinks, incidentally)
174 unless (-r $full_path) {
175 warn "Directory/symlink $full_path not readable";
176 next;
177 }
178
179 # check $prune_qr
180 my $subdir = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry";
181 if (defined $prune_qr) {
182 my $prune_string = $prune_full ? $subdir : $dir_entry;
183 next if $prune_string =~ m/$prune_qr/;
184 }
185
186 # everything looks good, time to recurse!
187 push @matches, listFilesRecursiveHelper($base_dir, $subdir, $match_qr, $prune_qr, $match_full, $prune_full);
188 } elsif (-f $full_path or -p $full_path or -S $full_path) {
189 my $file = ($curr_dir eq "") ? $dir_entry : "$curr_dir/$dir_entry";
190 my $match_string = $match_full ? $file : $dir_entry;
191 if (not defined $match_string or $match_string =~ m/$match_qr/) {
192 push @matches, $file;
193 }
194 }
195 }
196
197 return @matches;
198}
199
200# A very useful macro for making sure that all of the directories to a file have
201# been constructed.
202sub surePathToFile($$) {
203 # constructs intermediate
204 # the input path must be the path relative to this starting directory
205 my $start_directory = shift;
206 my $path = shift;
207 my $delim = "/"; #&getDirDelim();
208 unless ($start_directory and $path ) {
209 warn "missing directory<br> surePathToFile start_directory path ";
210 return '';
211 }
212 # use the permissions/group on the start directory itself as a template
213 my ($perms, $groupID) = (stat $start_directory)[2,5];
214 #warn "&urePathToTmpFile: perms=$perms groupID=$groupID\n";
215
216 # if the path starts with $start_directory (which is permitted but optional) remove this initial segment
217 $path =~ s|^$start_directory|| if $path =~ m|^$start_directory|;
218 #$path = convertPath($path);
219
220
221 # find the nodes on the given path
222 my @nodes = split("$delim",$path);
223
224 # create new path
225 $path = $start_directory; #convertPath("$tmpDirectory");
226
227 while (@nodes>1) {
228 $path = $path . shift (@nodes) . "/"; #convertPath($path . shift (@nodes) . "/");
229 #FIXME this make directory command may not be fool proof.
230 unless (-e $path) {
231 mkdir($path, $perms)
232 or warn "Failed to create directory $path";
233 }
234
235 }
236
237 $path = $path . shift(@nodes); #convertPath($path . shift(@nodes));
238 return $path;
239}
240
241sub makeTempDirectory($$) {
242 my ($parent, $basename) = @_;
243 # Loop until we're able to create a directory, or it fails for some
244 # reason other than there already being something there.
245 my $triesRemaining = MKDIR_ATTEMPTS;
246 my ($fullPath, $success);
247 do {
248 my $suffix = join "", map { ('A'..'Z','a'..'z','0'..'9')[int rand 62] } 1 .. 8;
249 $fullPath = "$parent/$basename.$suffix";
250 $success = mkdir $fullPath;
251 } until ($success or not $!{EEXIST});
252 die "Failed to create directory $fullPath: $!"
253 unless $success;
254 return $fullPath;
255}
256
257sub removeTempDirectory($) {
258 my ($dir) = @_;
259 rmtree($dir, 0, 0);
260}
261
262################################################################################
263# Date/time processing
264################################################################################
265
266=head2 Date/time processing
267
268=over
269
270=item $dateTime = parseDateTime($string, $display_tz)
271
272Parses $string as a datetime. If $display_tz is given, $string is assumed to be
273in that timezone. Otherwise, the server's timezone is used. The result,
274$dateTime, is an integer UNIX datetime (epoch) in the server's timezone.
275
276=cut
277
278# This is a modified version of the subroutine of the same name from WeBWorK
279# 1.9.05's scripts/FILE.pl (v1.13). It has been modified to understand time
280# zones. The time zone specification must appear at the end of the string and be
281# preceded by whitespace. The return value is a list consisting of the following
282# elements:
283#
284# ($second, $minute, $hour, $day, $month, $year, $zone)
285#
286# $second, $minute, $hour, $day, and $month are zero-indexed. $year is the
287# number of years since 1900. $zone is a string (hopefully) representing the
288# time zone.
289#
290# Error handling has also been improved. Exceptions are now thrown for errors,
291# and more information is given abou the nature of errors.
292#
293sub unformatDateAndTime {
294 my ($string) = @_;
295 my $orgString =$string;
296 $string =~ s|^\s+||;
297 $string =~ s|\s+$||;
298 $string =~ s|at| at |i; ## OK if forget to enter spaces or use wrong case
299 $string =~ s|AM| AM|i; ## OK if forget to enter spaces or use wrong case
300 $string =~ s|PM| PM|i; ## OK if forget to enter spaces or use wrong case
301 $string =~ s|,| at |; ## start translating old form of date/time to new form
302
303 my($date,$time,$AMPM,$TZ) = split(/\s+/,$string);
304 unless ($time =~ /:/) {
305 { ##bare block for 'case" structure
306 $time =~ /(\d\d)(\d\d)/;
307 my $tmp_hour = $1;
308 my $tmp_min = $2;
309 if ($tmp_hour eq '00') {$time = "12:$tmp_min"; $AMPM = 'AM';last;}
310 if ($tmp_hour eq '12') {$time = "12:$tmp_min"; $AMPM = 'PM';last;}
311 if ($tmp_hour < 12) {$time = "$tmp_hour:$tmp_min"; $AMPM = 'AM';last;}
312 if ($tmp_hour < 24) {
313 $tmp_hour = $tmp_hour - 12;
314 $time = "$tmp_hour:$tmp_min";
315 $AMPM = 'PM';
316 }
317 } ##end of bare block for 'case" structure
318
319 }
320
321 my ($mday, $mon, $year, $wday, $yday,$sec, $pm, $min, $hour);
322 $sec=0;
323 $time =~ /^([0-9]+)\s*\:\s*([0-9]*)/;
324 $min=$2;
325 $hour = $1;
326 if ($hour < 1 or $hour > 12) {
327 die "Incorrect date/time format \"$orgString\". Hour must be in the range [1,12].
328 Correct format is MM/DD/YYYY at HH:MM AMPM ZONE (e.g. \"03/29/2004 at 06:00am EST\")\n"
329 }
330 if ($min < 0 or $min > 59) {
331 die "Incorrect date/time format $orgString. Minute must be in the range [0-59]. Correct format is MM/DD/YYYY at HH:MM AMPM ZONE\n";
332 }
333 $pm = 0;
334 $pm = 12 if ($AMPM =~/PM/ and $hour < 12);
335 $hour += $pm;
336 $hour = 0 if ($AMPM =~/AM/ and $hour == 12);
337 $date =~ m!([0-9]+)\s*/\s*([0-9]+)/\s*([0-9]+)! ;
338 $mday =$2;
339 $mon=($1-1);
340 if ($mday < 1 or $mday > 31) {
341 die "Incorrect date/time format $orgString. Day must be in the range [1,31]. Correct format is MM/DD/YY at HH:MM AMPM ZONE\n";
342 }
343 if ($mon < 0 or $mon > 11) {
344 die "Incorrect date/time format $orgString. Month must be in the range [1,12]. Correct format is MM/DD/YY at HH:MM AMPM ZONE\n";
345 }
346 $year=$3;
347 $wday="";
348 $yday="";
349 return ($sec, $min, $hour, $mday, $mon, $year, $TZ);
350}
351
352
353sub parseDateTime($;$) {
354 my ($string, $display_tz) = @_;
355 $display_tz ||= "local";
356 #warn "parseDateTime('$string', '$display_tz')\n";
357
358 # use WeBWorK 1 date parsing routine
359 my ($second, $minute, $hour, $day, $month, $year, $zone) = unformatDateAndTime($string);
360 my $zone_str = defined $zone ? $zone : "UNDEF";
361 #warn "\tunformatDateAndTime: $second $minute $hour $day $month $year $zone_str\n";
362
363 # DateTime expects month 1-12, not 0-11
364 $month++;
365
366 # Do what Time::Local does to ambiguous years
367 {
368 my $ThisYear = (localtime())[5]; # FIXME: should be relative to $string's timezone
369 my $Breakpoint = ($ThisYear + 50) % 100;
370 my $NextCentury = $ThisYear - $ThisYear % 100;
371 $NextCentury += 100 if $Breakpoint < 50;
372 my $Century = $NextCentury - 100;
373 my $SecOff = 0;
374
375 if ($year >= 1000) {
376 # leave alone
377 } elsif ($year < 100 and $year >= 0) {
378 $year += ($year > $Breakpoint) ? $Century : $NextCentury;
379 $year += 1900;
380 } else {
381 $year += 1900;
382 }
383 }
384
385 my $epoch;
386
387 if (defined $zone and $zone ne "") {
388 if (DateTime::TimeZone->is_valid_name($zone)) {
389 #warn "\t\$zone is valid according to DateTime::TimeZone\n";
390
391 my $dt = new DateTime(
392 year => $year,
393 month => $month,
394 day => $day,
395 hour => $hour,
396 minute => $minute,
397 second => $second,
398 time_zone => $zone,
399 );
400 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
401
402 $epoch = $dt->epoch;
403 #warn "\t\$dt->epoch = $epoch\n";
404 } else {
405 #warn "\t\$zone is invalid according to DateTime::TimeZone, so we ask Time::Zone\n";
406
407 # treat the date/time as UTC
408 my $dt = new DateTime(
409 year => $year,
410 month => $month,
411 day => $day,
412 hour => $hour,
413 minute => $minute,
414 second => $second,
415 time_zone => "UTC",
416 );
417 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
418
419 # convert to an epoch value
420 my $utc_epoch = $dt->epoch
421 or die "Date/time '$string' not representable as an epoch. Get more bits!\n";
422 #warn "\t\$utc_epoch = $utc_epoch\n";
423
424 # get offset for supplied timezone and utc_epoch
425 my $offset = tz_offset($zone, $utc_epoch) or die "Time zone '$zone' not recognized.\n";
426 #warn "\t\$zone is valid according to Time::Zone (\$offset = $offset)\n";
427
428 #$epoch = $utc_epoch + $offset;
429 ##warn "\t\$epoch = \$utc_epoch + \$offset = $epoch\n";
430
431 $dt->subtract(seconds => $offset);
432 #warn "\t\$dt - \$offset = ", $dt->strftime(DATE_FORMAT), "\n";
433
434 $epoch = $dt->epoch;
435 #warn "\t\$epoch = $epoch\n";
436 }
437 } else {
438 #warn "\t\$zone not supplied, using \$display_tz\n";
439
440 my $dt = new DateTime(
441 year => $year,
442 month => $month,
443 day => $day,
444 hour => $hour,
445 minute => $minute,
446 second => $second,
447 time_zone => $display_tz,
448 );
449 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
450
451 $epoch = $dt->epoch;
452 #warn "\t\$epoch = $epoch\n";
453 }
454
455 return $epoch;
456}
457
458=item $string = formatDateTime($dateTime, $display_tz)
459
460Formats the UNIX datetime $dateTime in the standard WeBWorK datetime format.
461$dateTime is assumed to be in the server's time zone. If $display_tz is given,
462the datetime is converted from the server's timezone to the timezone specified.
463
464=cut
465
466sub formatDateTime($;$) {
467 my ($dateTime, $display_tz) = @_;
468 $display_tz ||= "local";
469 #warn "formatDateTime('$dateTime', '$display_tz')\n";
470
471 my $dt = DateTime->from_epoch(epoch => $dateTime, time_zone => $display_tz);
472 #warn "\t\$dt = ", $dt->strftime(DATE_FORMAT), "\n";
473 return $dt->strftime(DATE_FORMAT);
474}
475
476=item $string = textDateTime($string_or_dateTime)
477
478Accepts a UNIX datetime or a formatted string, returns a formatted string.
479
480=cut
481
482sub textDateTime($) {
483 return ($_[0] =~ m/^\d*$/) ? formatDateTime($_[0]) : $_[0];
484}
485
486=item $dateTIme = intDateTime($string_or_dateTime)
487
488Accepts a UNIX datetime or a formatted string, returns a UNIX datetime.
489
490=cut
491
492sub intDateTime($) {
493 return ($_[0] =~ m/^\d*$/) ? $_[0] : parseDateTime($_[0]);
494}
495
496=back
497
498=cut
499
500################################################################################
501# Logging
502################################################################################
503
504sub writeLog($$@) {
505 my ($ce, $facility, @message) = @_;
506 unless ($ce->{webworkFiles}->{logs}->{$facility}) {
507 warn "There is no log file for the $facility facility defined.\n";
508 return;
509 }
510 my $logFile = $ce->{webworkFiles}->{logs}->{$facility};
511 local *LOG;
512 if (open LOG, ">>", $logFile) {
513 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n";
514 close LOG;
515 } else {
516 warn "failed to open $logFile for writing: $!";
517 }
518}
519
520sub writeCourseLog($$@) {
521 my ($ce, $facility, @message) = @_;
522 unless ($ce->{courseFiles}->{logs}->{$facility}) {
523 warn "There is no course log file for the $facility facility defined.\n";
524 return;
525 }
526 my $logFile = $ce->{courseFiles}->{logs}->{$facility};
527 local *LOG;
528 if (open LOG, ">>", $logFile) {
529 print LOG "[", time2str("%a %b %d %H:%M:%S %Y", time), "] @message\n";
530 close LOG;
531 } else {
532 warn "failed to open $logFile for writing: $!";
533 }
534}
535
536# $ce - a WeBWork::CourseEnvironment object
537# $function - fully qualified function name
538# $details - any information, do not use the characters '[' or ']'
539# $beginEnd - the string "begin", "intermediate", or "end"
540# use the intermediate step begun or completed for INTERMEDIATE
541# use an empty string for $details when calling for END
542sub writeTimingLogEntry($$$$) {
543 my ($ce, $function, $details, $beginEnd) = @_;
544 return unless defined $ce->{webworkFiles}->{logs}->{timing};
545 $beginEnd = ($beginEnd eq "begin") ? ">" : ($beginEnd eq "end") ? "<" : "-";
546 writeLog($ce, "timing", "$$ ".time." $beginEnd $function [$details]");
547}
548
549################################################################################
550# Data munging
551################################################################################
552
553sub list2hash(@) {
554 map {$_ => "0"} @_;
555}
556
557sub refBaseType($) {
558 my $ref = shift;
559 $ref =~ m/(\w+)\(/; # this might not be robust...
560 return $1;
561}
562
563sub ref2string($;$);
564sub ref2string($;$) {
565 my $ref = shift;
566 my $dontExpand = shift || {};
567 my $refType = ref $ref;
568 my $result;
569 if ($refType and not $dontExpand->{$refType}) {
570 my $baseType = refBaseType($ref);
571 $result .= '<font size="1" color="grey">' . $refType;
572 $result .= " ($baseType)" if $baseType and $refType ne $baseType;
573 $result .= ":</font><br>";
574 $result .= '<table border="1" cellpadding="2">';
575 if ($baseType eq "HASH") {
576 my %hash = %$ref;
577 foreach (sort keys %hash) {
578 $result .= '<tr valign="top">';
579 $result .= "<td>$_</td>";
580 $result .= "<td>" . ref2string($hash{$_}, $dontExpand) . "</td>";
581 $result .= "</tr>";
582 }
583 } elsif ($baseType eq "ARRAY") {
584 my @array = @$ref;
585 # special case for Problem, Set, and User objects, which are defined
586 # using lists and contain a @FIELDS package variable:
587 no strict 'refs';
588 my @FIELDS = eval { @{$refType."::FIELDS"} };
589 use strict 'refs';
590 undef @FIELDS unless scalar @FIELDS == scalar @array and not $@;
591 foreach (0 .. $#array) {
592 $result .= '<tr valign="top">';
593 $result .= "<td>$_</td>";
594 $result .= "<td>".$FIELDS[$_]."</td>" if @FIELDS;
595 $result .= "<td>" . ref2string($array[$_], $dontExpand) . "</td>";
596 $result .= "</tr>";
597 }
598 } elsif ($baseType eq "SCALAR") {
599 my $scalar = $$ref;
600 $result .= '<tr valign="top">';
601 $result .= "<td>$scalar</td>";
602 $result .= "</tr>";
603 } else {
604 # perhaps a coderef? in any case, i don't feel like dealing with it!
605 $result .= '<tr valign="top">';
606 $result .= "<td>$ref</td>";
607 $result .= "</tr>";
608 }
609 $result .= "</table>"
610 } else {
611 $result .= defined $ref ? $ref : '<font color="red">undef</font>';
612 }
613}
614
615sub decodeAnswers($) {
616 my $string = shift;
617 return unless defined $string and $string;
618 my @array = split m/##/, $string;
619 $array[$_] =~ s/\\#\\/#/g foreach 0 .. $#array;
620 push @array, "" if @array%2;
621 return @array; # it's actually a hash ;)
622}
623
624sub encodeAnswers(\%\@) {
625 my %hash = %{ shift() };
626 my @order = @{ shift() };
627 my $string = "";
628 foreach my $name (@order) {
629 my $value = defined $hash{$name} ? $hash{$name} : "";
630 $name =~ s/#/\\#\\/g; # this is a WEIRD way to escape things
631 $value =~ s/#/\\#\\/g; # and it's not my fault!
632 if ($value =~ m/\\$/) {
633 # if the value ends with a backslash, string2hash will
634 # interpret that as a normal escape sequence (not part
635 # of the weird pound escape sequence) if the next
636 # character is &. So we have to protect against this.
637 # will adding a spcae at the end of the last answer
638 # hurt anything? i don't think so...
639 $value .= " ";
640 }
641 $string .= "$name##$value##"; # this is also not my fault
642 }
643 $string =~ s/##$//; # remove last pair of hashs
644 return $string;
645}
646
647sub max(@) {
648 my $soFar;
649 foreach my $item (@_) {
650 $soFar = $item unless defined $soFar;
651 if ($item > $soFar) {
652 $soFar = $item;
653 }
654 }
655 return defined $soFar ? $soFar : 0;
656}
657
658sub pretty_print_rh($) {
659 my $rh = shift;
660 foreach my $key (sort keys %{$rh}) {
661 warn " $key => ",$rh->{$key},"\n";
662 }
663}
664
665sub cryptPassword($) {
666 my ($clearPassword) = @_;
667 my $salt = join("", ('.','/','0'..'9','A'..'Z','a'..'z')[rand 64, rand 64]);
668 my $cryptPassword = crypt($clearPassword, $salt);
669 return $cryptPassword;
670}
671
672# from the Perl Cookbook, first edition, page 25:
673sub dequote($) {
674 local $_ = shift;
675 my ($white, $leader); # common whitespace and common leading string
676 if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) {
677 ($white, $leader) = ($2, quotemeta($1));
678 } else {
679 ($white, $leader) = (/^(\s+)/, '');
680 }
681 s/^\s*?$leader(?:$white)?//gm;
682 return $_;
683}
684
685sub undefstr($@) {
686 map { defined $_ ? $_ : $_[0] } @_[1..$#_];
687}
688
689################################################################################
690# Sorting
691################################################################################
692
693# p. 101, Camel, 3rd ed.
694# The <=> and cmp operators return -1 if the left operand is less than the
695# right operand, 0 if they are equal, and +1 if the left operand is greater
696# than the right operand.
697sub sortByName($@) {
698 my ($field, @items) = @_;
699 return sort {
700 my @aParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $a->$field : $a;
701 my @bParts = split m/(?<=\D)(?=\d)|(?<=\d)(?=\D)/, defined $field ? $b->$field : $b;
702 while (@aParts and @bParts) {
703 my $aPart = shift @aParts;
704 my $bPart = shift @bParts;
705 my $aNumeric = $aPart =~ m/^\d*$/;
706 my $bNumeric = $bPart =~ m/^\d*$/;
707
708 # numbers should come before words
709 return -1 if $aNumeric and not $bNumeric;
710 return +1 if not $aNumeric and $bNumeric;
711
712 # both have the same type
713 if ($aNumeric and $bNumeric) {
714 next if $aPart == $bPart; # check next pair
715 return $aPart <=> $bPart; # compare numerically
716 } else {
717 next if $aPart eq $bPart; # check next pair
718 return $aPart cmp $bPart; # compare lexicographically
719 }
720 }
721 return +1 if @aParts; # a has more sections, should go second
722 return -1 if @bParts; # a had fewer sections, should go first
723 } @items;
724}
725
7261;
Legend:
Removed from v.410  
changed lines
  Added in v.2891
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9