#!/usr/bin/perl #################################################################### # Script: | FAQ Manager (Interaction Program) # # Version: | 1.0 # # By: | Jason Berry (i2 Services, Inc. / CGI World) # # Contact: | jason@cgi-world.com # # WWWeb: | http://www.cgi-world.com # # Copyright: | 1996-2000 I2 Services, Inc. / CGI World # # Released: | December 1st, 1999 # # | # #################################################################### # By using this software, you have agreed to the license # # agreement packaged with this program. # # # # Do Not Edit Below This Line - Violation of Product License # # Agreement. # #################################################################### $SIG{__DIE__} = $SIG{__WARN__} = \&HTML_Error; # show error msg on die/warn if ($0=~m#^(.*)\\#){ $base_dir = "$1"; } elsif ($0=~m#^(.*)/# ){ $base_dir = "$1"; } else {`pwd` =~ /(.*)/; $base_dir = "$1"; } $cgiurl = $ENV{'SCRIPT_NAME'}; $|++; # Files & Dirs Used: #################### $data_dir = "$base_dir/faq_manager"; $template_dir = "$data_dir/templates"; $group_dbase = "$data_dir/faq_groups.dat"; $mailfile_dir = "$data_dir/mail_files"; $newquestion_dbase = "$data_dir/new_questions.dat"; $filelock = "$data_dir/filelock2"; $config_dbase = "$data_dir/faq_config.dat"; ### Database fields @ifields = qw(num new_question full_name email); @ffields = qw(num sort_num question answer updated); @gfields = qw(num sort_num group description template output_type); @config_fields = qw(num admin_password faq_directory faq_url index_file index_template file_extension mailprog admin_email use_mailprog interact_url blat_smtp_server blat_port admin_cgi_url); &DB_Load($config_dbase,$filelock,\@config_fields,1); %in = &ReadForm; print "Content-Type: text/html\n\n"; if($email_to) { # print " $in{'faq_id_1'} || $in{'main_1.4'} $in{'main_1.5'}\n"; $test2 = "main_1.5"; if($in{'main_1.5'}) { print "stupid shit works up here :) " }; } ######################################################## # FAQ Generator - Interacttion Script v1.0 (e-Mail FAQs): if(!$ENV{'QUERY_STRING'}) { # Prepare FAQ E-mail to Send: ##################################################### if($email_to =~ /.*\@.*\..*/) { &Template("$mailfile_dir/_faqs_by_email.txt"); ###### $sortcode = sub { $a_name = &DB_Field("sort_num",\@gfields,$a); $b_name = &DB_Field("sort_num",\@gfields,$b); $b_name <=> $a_name; }; ###### $rowcode = sub { if($in{"faq_id_$num"} || $in{"main_$num"}) { $group = uc($group); $faq_mail_body .= &Cell("group_text"); $main_num = $num; &Email_Group; } }; &DB_List($group_dbase,$filelock,\@gfields,$rowcode,$sortcode); # Send out mail (Using Sendmail) ################################ if($use_mailprog eq "sendmail" && $admin_email && $mailprog) { open(MAIL,"|$mailprog -t"); print MAIL "To: $email_to\n"; print MAIL "From: $admin_email \n"; print MAIL "Subject: Requested Frequently Asked Questions...\n"; print MAIL "X-Courtesy-Of: FAQ Manager by I2 Services, Inc.\n\n"; print MAIL &Template("$mailfile_dir/_faqs_by_email.txt"); close(MAIL); } # Send Out Mail (Using Blat Mail) ################################# elsif($use_mailprog eq "blatmail" && $admin_email) { $tempfile = "$data_dir/temp_faqemail.txt"; &FileLock("$filelock"); open(MAIL,">$tempfile") || die("Cannot open $tempfile -- Check Directory Permissions : $!"); #Date $date = localtime(time); $subject = "Requested Frequently Asked Questions..."; print MAIL "-" x 75 . "\n\n"; print MAIL &Template("$mailfile_dir/_faqs_by_email.txt"); close(MAIL); $blatcmd = qq($base_dir/blat.exe $tempfile -t "$email_to" -f "$admin_email" -s "$subject" -server $blat_smtp_server -port $blat_port -noh2 -q); system("$blatcmd"); unlink($tempfile); &FileUnlock("$filelock") } $questions_sent = join('',@questions_sent); print &Template("$template_dir/_faqs_sent.html"); exit; } &Template("$template_dir/_email_faqs.html"); ###### $sortcode = sub { $a_name = &DB_Field("sort_num",\@gfields,$a); $b_name = &DB_Field("sort_num",\@gfields,$b); $b_name <=> $a_name; }; ###### $rowcode = sub { $main_num = $num; $faq_listing .= &Cell("faq_groups"); &List_FAQS; }; &DB_List($group_dbase,$filelock,\@gfields,$rowcode,$sortcode); print &Template("$template_dir/_email_faqs.html"); exit; } ######################################################### # FAQ Generator - Interacttion Script v1.0 (e-Mail Group): sub Email_Group { ###### $faq_sortcode = sub { $a_name = &DB_Field("sort_num",\@gfields,$a); $b_name = &DB_Field("sort_num",\@gfields,$b); $b_name <=> $a_name; }; ###### $faq_rowcode = sub { $test = "main_$main_num.$num"; if($in{"faq_id_$main_num"} || $in{"main_$main_num.$num"}) { $answer =~ s/]*href="(\w+:[^>]*)"[^>]*>/($1) /gis; $answer =~ s/<[^>]*>//gs; $faq_mail_body .= &Cell("q_and_a_text"); $question_sent = "
  • $question
    \n"; push(@questions_sent,$question_sent); } }; $group_file = "$data_dir/$main_num.dat"; &DB_List($group_file,$filelock,\@ffields,$faq_rowcode,$faq_sortcode); } ######################################################### # FAQ Generator - Interacttion Script v1.0 (List FAQs): sub List_FAQS { $faqs_file = "$data_dir/$num.dat"; ###### $question_sortcode = sub { $a_name = &DB_Field("sort_num",\@gfields,$a); $b_name = &DB_Field("sort_num",\@gfields,$b); $b_name <=> $a_name; }; ###### $question_code = sub { if($output_type eq "multiple") { $question_link = "$main_num.$num$file_extension"; } else { $question_link = "$main_num$file_extension#$num"; } $faq_listing .= &Cell("single_faqs") ; }; &DB_List($faqs_file,$filelock,\@ffields,$question_code,$question_sortcode); } ######################################################## # FAQ Generator - Interacttion Script v1.0 (Main Menu): if($ENV{'QUERY_STRING'} =~ /^search/i) { &Template("$template_dir/_search_faqs.html"); if($faq_keyword) { $faq_keyword =~ s/,/|/g; opendir(FAQDIR,"$faq_directory"); @faq_files = readdir(FAQDIR); closedir(FAQDIR); $matches = 0; foreach$ffile(sort @faq_files) { if($ffile =~ /$file_extension/i) { undef($FAQ_FILE); open(FILE,"$faq_directory/$ffile") || next; while () { $FAQ_FILE .= $_; } close(FILE); if($FAQ_FILE =~ m|(.+?)|is) { $title = $1; } $FAQ_FILE =~ s/<[^>]*>//gs; if($FAQ_FILE =~ /$faq_keyword/gi) { $matches++; if(!$title) { $title = "No Title" }; $faq_matches .= &Cell("search_match"); } } } $matches_count = "
  • Matches Found: $matches"; $faq_keyword =~ s/\|/,/g; } print &Template("$template_dir/_search_faqs.html"); exit; } ######################################################## # FAQ Generator - Interaction Script v1.0 (Main Menu): if($ENV{'QUERY_STRING'} =~ /^submit_question/i) { # Take New Question & Proceed if Required Values: ################################################### if($new_question && $full_name) { if($email !~ /.*\@.*\..*/) { undef($email) }; &Template("$template_dir/_question_submitted.html"); &DB_Add($newquestion_dbase, $filelock, \@ifields); &DB_Load($newquestion_dbase,$filelock, \@ifields,$nnum); $new_question = &DB_Decode("$new_question"); $from_name = "$full_name"; if($email) { $full_name = "$full_name" }; if($email =~ /.*\@.*\..*/) { $from = "$email" } else { $from = "$admin_email" }; # Send out mail (Using Sendmail) ################################ $new_questions_url = "$admin_cgi_url$\?new_questions=view"; if($use_mailprog eq "sendmail" && $admin_email && $mailprog) { open(MAIL,"|$mailprog -t"); print MAIL "To: $admin_email\n"; print MAIL "From: $from ($from_name)\n"; print MAIL "Subject: Question Submitted via FAQ Manager\n"; print MAIL "X-Courtesy-Of: FAQ Manager by I2 Services, Inc.\n\n"; $new_question =~ s/
    /\n/gi; &Template("$mailfile_dir/_submitted_question.txt"); print MAIL &Template("$mailfile_dir/_submitted_question.txt"); close(MAIL); } # Send Out Mail (Using Blat Mail) ################################# elsif($use_mailprog eq "blatmail" && $admin_email) { $tempfile = "$data_dir/tempemail.txt"; &FileLock("$filelock"); open(MAIL,">$tempfile") || die("Cannot open $tempfile -- Check Directory Permissions : $!"); #Date $date = localtime(time); $subject = "Submitted Question by FAQ Manager by I2 Services, Inc."; print MAIL "-" x 75 . "\n\n"; &Template("$mailfile_dir/_submitted_question.txt"); $new_question =~ s/
    /\n/gi; print MAIL &Template("$mailfile_dir/_submitted_question.txt"); close(MAIL); $blatcmd = qq($base_dir/blat.exe $tempfile -t "$admin_email" -f "$from" -s "$subject" -server $blat_smtp_server -port $blat_port -noh2 -q); system("$blatcmd"); unlink($tempfile); &FileUnlock($filelock); } $new_question =~ s/\n/
    /g; print &Template("$template_dir/_question_submitted.html"); exit; } # Show New Question Form: ################################################### else { &Template("$template_dir/_submit_question.html"); print &Template("$template_dir/_submit_question.html"); exit; } } # HTML_Error : Display an HTML Error Message & Exit: #################################################### sub HTML_Error { print "Content-type: text/html\n\n"; &DB_Unlock($filelock); # File Unlock print "@_"; exit; } # Convert Month: #################################################### sub convert_month { if($month eq "0") { $month = "January" }; if($month eq "1") { $month = "February" }; if($month eq "2") { $month = "March" }; if($month eq "3") { $month = "April" }; if($month eq "4") { $month = "May" }; if($month eq "5") { $month = "June" }; if($month eq "6") { $month = "July" }; if($month eq "7") { $month = "August" }; if($month eq "8") { $month = "September" }; if($month eq "9") { $month = "October" }; if($month eq "10") { $month = "November" }; if($month eq "11") { $month = "December" }; } # Parse Form: #################################################### sub ReadForm { my($max) = $_[1]; # Max Input Size my($name,$value,$pair,@pairs,$buffer,%hash); # localize variables # Check input size if max input size is defined if ($max && ($ENV{'CONTENT_LENGTH'}||length $ENV{'QUERY_STRING'}) > $max) { die("ReadForm : Input exceeds max input limit of $max bytes\n"); } # Read GET or POST form into $buffer if ($ENV{'REQUEST_METHOD'} eq 'POST') { read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); } elsif ($ENV{'REQUEST_METHOD'} eq 'GET') { $buffer = $ENV{'QUERY_STRING'}; } @pairs = split(/&/, $buffer); # Split into name/value pairs foreach $pair (@pairs) { # foreach pair ($name, $value) = split(/=/, $pair); # split into $name and $value $value =~ tr/+/ /; # replace "+" with " " $value =~ s/%([A-F0-9]{2})/pack("C", hex($1))/egi; # replace %hex with char if($name eq "faq_id") { $hash{"faq_id_$value"} = $value; if ($value =~ m|^(.+?).|is) { $test = $1; } $hash{"main_$value"} = "true"; $hash{"main_$test"} = "true"; } $hash{$name} = $value; $$name = "$value"; } return %hash; } # ------------------------------------------------------------------------ # Template : Open a template file, translate variables and return contents # # usage : print &Template("$cgidir/filename.html",'html'); # ------------------------------------------------------------------------ sub Template { local(*FILE); my($hash) = $_[1]; if (!$_[0]) { return "
    \nTemplate : No file was specified
    \n"; } elsif (!-e "$_[0]") { return "
    \nTemplate : File '$_[0]' does not exist
    \n"; } else { open(FILE, "<$_[0]") || return "
    \nTemplate : Could open $_[0]
    \n"; while () { $FILE .= $_; } close(FILE); for ($FILE) { s//\1/gi; # show hidden inserts s/(?:\r\n|\n)?(.*?)/ $CELL{$1}=$2;''/ges; # read/remove template cells if ($hash) { s/\$(\w+)\$/$hash->$1/g; } # translate $scalars$ else { s/\$(\w+)\$/${$1}/g; } } } return $FILE; } # ------------------------------------------------------------------------ # Cell : Return a template cell with translated variables. # Note: Before you can read a cell you need to load the template. # # usage : print &Cell("cellname"); # ------------------------------------------------------------------------ sub Cell { my($CELL); my($hash) = $_[1]; for (0..$#_) { if ($_[$_]) { $CELL .= $CELL{$_[$_]}; }} if (!$_[0]) { return "
    \nCell : No cell was specified
    \n"; } elsif (!$CELL) { return "
    \nCell : Cell '$_[0]' is not defined
    \n"; } else { if ($hash) { $CELL =~ s/\$(\w+)\$/$hash->{$1}/g; } # translate $scalars$ else { $CELL =~ s/\$(\w+)\$/${$1}/g; } } # translate $scalars$ return $CELL; } # ---------------------------------------------------------------------------- # FileLock : File locking/unlocking Perl routines. # # Usage : &FileLock("$lockdir"); # : &FileUnlock("$lockdir"); # ---------------------------------------------------------------------------- sub FileLock { my($i); # sleep counter while (!mkdir($_[0],0777)) { # if there already is a lock sleep 1; # sleep for 1 sec and try again if (++$i>60) { die("File_Lock : Can't create filelock : $!\n"); } } } sub FileUnlock { rmdir($_[0]); # remove file lock dir } # ---------------------------------------------------------------------------- # MIME64 : MIME64 encoding/decoding Perl routines. MIME64 is a common base64 # encoding scheme documented in RFC1341, section 5.2. # # Usage : $mime64_text = &MIME64_Encode("$plaintext"); # : $plaintext = &MIME64_Decode("$mime64_text"); # ---------------------------------------------------------------------------- sub MIME64_Encode { my($in) = $_[0]; # text to encode my(@b64) = ((A..Z,a..z,0..9),'+','/'); # Base 64 char set to use my($out) = unpack("B*",$in); # Convert to binary $out=~ s/(\d{6}|\d+$)/$b64[ord(pack"B*","00$1")]/ge; # convert 3 bytes to 4 while (length($out)%4) { $out .= "="; } # Pad string with '=' return $out; # Return encoded text } sub MIME64_Decode { my($in) = $_[0]; # encoded text to decode my(%b64); # Base 64 char set hash my($out); # decoded text variable for((A..Z,a..z,0..9),'+','/'){ $b64{$_} = $i++ } # Base 64 char set to use $in = $_[0] || return "MIME64 : Nothing to decode"; # Get input or return $in =~ s/[^A-Za-z0-9+\/]//g; # Remove invalid chars $in =~ s/[A-Za-z0-9+\/]/unpack"B*",chr($b64{$&})/ge; # b64 offset val -> bin $in =~ s/\d\d(\d{6})/$1/g; # Convert 8 bits to 6 $in =~ s/\d{8}/$out.=pack("B*",$&)/ge; # Convert bin to text return $out; # Return decoded text } # ---------------------------------------------------------------------------- # URL : URL encoding/decoding Perl routines. URL encoding is an common # encoding scheme where non A-Za-z0-9+*.@_- characters are replaced # with a character triplet of "%" followed by the two hex digits. # # Usage : $URL_encoded = &URL_Encode("$plaintext"); # : $plaintext = &URL_Decode("$URL_encoded"); # ---------------------------------------------------------------------------- sub URL_Encode { my($text) = $_[0]; # text to URL encode $text =~ tr/ /+/; # replace " " with "+" $text =~ s/[^A-Za-z0-9\+\*\.\@\_\-]/ # replace odd chars uc sprintf("%%%02x",ord($&))/egx; # with %hex value return $text; # return URL encoded text } sub URL_Decode { my($text) = $_[0]; # URL encoded text to decode $text =~ tr/+/ /; # replace "+" with " " $text =~ s/%([A-F0-9]{2})/pack("C", hex($1))/egi; # replace %hex with chars return $text; # return decoded plain text } # ---------------------------------------------------------------------------- # Cookie : Perl routines for setting/reading browser cookies. # : Cookies have a max size of 4k and each host can send up to 20. # # Usage : &SetCookie("name","value"); # : %cookie = &ReadCookie; # ---------------------------------------------------------------------------- sub SetCookie { my($cookie_info); my($name,$value,$exp,$path,$domain,$secure) = @_; # $name - cookie name (ie: username) # $value - cookie value (ie: "joe user") # $exp - exp date, cookie will be deleted at this date. Format: Wdy, DD-Mon-YYYY HH:MM:SS GMT # $path - Cookie is sent only when this path is accessed (ie: /); # $domain - Cookie is sent only when this domain is accessed (ie: .edis.org) # $secure - Cookie is sent only with secure https connection unless (defined $name) { die("SetCookie : Cookie name must be specified\n"); } if ($exp && $exp !~ /^[A-Z]{3}, \d\d-[A-Z]{3}-\d{4} \d\d:\d\d:\d\d GMT$/i) { die("SetCookie : Exp Dat format isn't: Wdy, DD-Mon-YYYY HH:MM:SS GMT\n"); } if ($name) { $name = &URL_Encode($name); } if ($value) { $value = &URL_Encode($value); } if ($exp) { $cookie_info .= "expires=$exp; "; } if ($path) { $cookie_info .= "path=$path; "; } if ($domain) { $cookie_info .= "domain=$domain; "; } if ($secure) { $cookie_info .= "secure; "; } print "Set-Cookie: $name=$value; $cookie_info\n"; } sub ReadCookie { my($cookie,$name,$value,%jar); foreach $cookie (split(/; /,$ENV{'HTTP_COOKIE'})) { # for each cookie sent ($name,$value) = split(/=/,$cookie); # split into name/value foreach($name,$value) { $_ = &URL_Decode($_); } # URL decode strings $$name = "$value"; # and put into %jar hash } return %jar; # return %jar hash } # ------------------------------------------------------------------------ # DB_List : Retrieve vars and execute a subroutine for each record in # the database, @fields are the var names for each field. # # example : &DB_List($datafile, $filelock, \@fields, \&rowcode, \&sortcode); # ------------------------------------------------------------------------ sub DB_List { ### Localize vars my($datafile) = $_[0]; # Database file my($filelock) = $_[1]; # File Lock Directory my(@fields) = @{$_[2]}; # Database Fields my($rowcode) = $_[3]; # routine to exec on each record my($sortcode) = $_[4]; # sort routine my(@records); # Records from Database ### Load Data if (-e $datafile) { if ($filelock) { &DB_Lock($filelock); } # File Lock open(FILE,"<$datafile") || die("DB_List : Error, Can't open $datafile. $!\n"); @records = ; # Load DB Records close(FILE); if ($filelock) { &DB_Unlock($filelock); } # File Unlock } if ($sortcode) { @records = sort { &$sortcode } @records; } # exec sort routine ### Get vars and exec subroutine for each record foreach (@records) { chomp $_; chomp $_; # chop return/nextline my(@rfields) = split(/\|/,$_); # Split record into fields ### Assign field data to variable for $i (0..$#fields) { # for each field name ${$fields[$i]} = &DB_Decode($rfields[$i]); # assign field data to var } ### Execute code for this record &$rowcode; # Execute Code } } # ------------------------------------------------------------------------ # DB_Add : Add a new record to the database and find an unused record # number. # # example : &DB_Add($datafile, $filelock, \@fields); # ------------------------------------------------------------------------ sub DB_Add { ### Localize vars my($datafile) = $_[0]; # Database file my($filelock) = $_[1]; # File Lock Directory my(@fields) = @{$_[2]}; # Database Fields my(%rnum); # Hash of record numbers my(@records); # Records from Database if ($filelock) { &DB_Lock($filelock); } # File Lock ### Load Data if (-e "$datafile") { open(FILE,"<$datafile") || die("DB_Add : Error, Can't open $datafile. $!\n"); @records = ; # Load DB Records close(FILE); } ### Find available record number foreach (@records) { chomp $_; chomp $_; # chop return/nextline my($rnum) = split(/\|/,$_); # Split record into fields $rnum{$rnum} = 1; # record record numbers } my($nnum) = 1; # Start new number from 1 while ($rnum{$nnum}) { $nnum++; } # If number is used add 1 ### Save data file with new record open(FILE,">$datafile") || die("DB_Add : Error, Can't write to $datafile. $!\n"); foreach (@records) { chomp $_; chomp $_; # chop return/nextline print FILE "$_\n"; # print out line } print FILE "$nnum|"; # New Record Number for $i (1..$#fields) { # for each field name ${$fields[$i]} = &DB_Encode(${$fields[$i]}); # Encode field for DB print FILE "${$fields[$i]}|"; # Print encoded field } print FILE "\n"; close(FILE); if ($filelock) { &DB_Unlock($filelock); } # File Unlock } # ------------------------------------------------------------------------ # DB_Save : Save a record number in the database # # example : &DB_Save($datafile, $filelock, \@fields, $record_num); # : returns 0 if record to be saved couldn't be found # ------------------------------------------------------------------------ sub DB_Save { ### Localize vars my($datafile) = $_[0]; # Database file my($filelock) = $_[1]; # File Lock Directory my(@fields) = @{$_[2]}; # Database Fields my($rnum) = int $_[3]; # Record Number to update my($rfound); # Record Found Flag my(@records); # Records from Database if ($filelock) { &DB_Lock($filelock); } # File Lock ### Load Data if (-e "$datafile") { open(FILE,"<$datafile") || die("DB_Save : Error, Can't open $datafile. $!\n"); @records = ; # Load DB Records close(FILE); } ### Save data file with new record open(FILE,">$datafile") || die("DB_Save : Error, Can't write to $datafile. $!\n"); foreach (@records) { chomp $_; chomp $_; # chop return/nextline my(@rfields) = split(/\|/,$_); # Split record into fields ### Check if this is the right record if ($rnum != $rfields[0]) { print FILE "$_\n"; } # if no match continue else { # matched, update record print FILE "$rnum|"; for $i (1..$#fields) { # for each field name ${$fields[$i]} = &DB_Encode(${$fields[$i]}); # Encode field for DB print FILE "${$fields[$i]}|"; # Print encoded field } print FILE "\n"; $rfound++; } } close(FILE); if ($filelock) { &DB_Unlock($filelock); } # File Unlock if ($rfound) { return 1; } # Record Found else { return 0; } # Record wasn't found } # ------------------------------------------------------------------------ # DB_Load : Load a record number from the database # # example : &DB_Load($datafile, $filelock, \@fields, $record_num); # ------------------------------------------------------------------------ sub DB_Load { ### Localize vars my($datafile) = $_[0]; # Database file my($filelock) = $_[1]; # File Lock Directory my(@fields) = @{$_[2]}; # Database Fields my($rnum) = int $_[3]; # Record Number to load my($rfound); # Record Found Flag my(@records); # Records from Database ### Load Data if (-e "$datafile") { if ($filelock) { &DB_Lock($filelock); } # File Lock open(FILE,"<$datafile") || die("DB_Load : Error, Can't open $datafile. $!\n"); @records = ; # Load DB Records close(FILE); if ($filelock) { &DB_Unlock($filelock); } # File Unlock } ### Find record number and assign variables for each field foreach (@records) { chomp $_; chomp $_; # chop return/nextline my(@rfields) = split(/\|/,$_); # Split record into fields ### Check if this is the right record if ($rnum == $rfields[0]) { ### Assign field data to variable for $i (0..$#fields) { # for each field name ${$fields[$i]} = &DB_Decode($rfields[$i]); # assign field data to var ${"$fields[$i]_${$fields[$i]}_selected"} = "selected"; ${"$fields[$i]_${$fields[$i]}_checked"} = "checked"; } $rfound++; } } if ($rfound) { return 1; } # Record Found else { return 0; } # Record wasn't found } # ------------------------------------------------------------------------ # DB_Del : Erase a record number from the database # # example : &DB_Del($datafile, $filelock, $record_num); # ------------------------------------------------------------------------ sub DB_Del { ### Localize vars my($datafile) = $_[0]; # Database file my($filelock) = $_[1]; # File Lock Directory my($rnum) = int $_[2]; # Record Number to load my($rfound); # Record Found Flag my(@records); # Records from Database if ($filelock) { &DB_Lock($filelock); } # File Lock ### Load Data if (-e "$datafile") { open(FILE,"<$datafile") || die("DB_Del : Error, Can't open $datafile. $!\n"); @records = ; # Load DB Records close(FILE); } ### Save Data open(FILE,">$datafile") || die("DB_Del : Error, Can't open $datafile. $!\n"); foreach (@records) { chomp $_; chomp $_; # chop return/nextline my(@rfields) = split(/\|/,$_); # Split record into fields ### Check if this is the right record if ($rnum == $rfields[0]) { $rfound++; } else { print FILE "$_\n"; } } close(FILE); if ($filelock) { &DB_Unlock($filelock); } # File Unlock if ($rfound) { return 1; } # Record Found else { return 0; } # Record wasn't found } # ---------------------------------------------------------------------------- # DB_Lock : Database locking/unlocking Perl routines. # A directory is created to flag the database as locked # # Usage : &DB_Lock("$lockdir"); # : &DB_Unlock("$lockdir"); # ---------------------------------------------------------------------------- sub DB_Lock { my($filelock) = $_[0]; # Filelock Dir my($i); # sleep counter while (!mkdir($filelock,0777)) { # attempt to make file lock (or) sleep 1; # sleep for 1 sec and try again if (++$i>50) { die("DB_Lock : Can't create filelock : $!\n"); } } } sub DB_Unlock { my($filelock) = $_[0]; # Filelock Dir rmdir($filelock); # remove file lock dir } # ---------------------------------------------------------------------------- # DB_Decode : Decode encoded DB field and return decoded string # # Usage : $decoded = &DB_Decode("$encoded"); # ---------------------------------------------------------------------------- sub DB_Decode { my($string) = $_[0]; # string to decode $string =~ s/%([A-F0-9]{2})/pack("C",hex($1))/egix; # decode string $string =~ s/\r\n/\n/gs; # replace \r\n with \n return $string; # return decoded string } # ---------------------------------------------------------------------------- # DB_Encode : Encode a DB field and return encoded string # : nextline, EOF, | and % are encoded so they # don't cause problems in the database # # Usage : $decoded = &DB_Decode("$encoded"); # ---------------------------------------------------------------------------- sub DB_Encode { my($string) = $_[0]; # string to decode $string =~ s/\r\n/\n/gs; # replace \r\n with \n $string =~ s/[\x1a\n\|\%]/uc sprintf("%%%02x",ord($&))/egx; # Encode string return $string; # return decoded string } # ---------------------------------------------------------------------------- # DB_Field : Split a record into fields and return the requested field. # This routine is used when sorting records by a specific field. # # Usage : $name = &DB_Field("name",\@fields,$record); # ---------------------------------------------------------------------------- sub DB_Field { my($fieldname) = $_[0]; # Field name to retrieve my(@fields) = @{$_[1]}; # Database Field Names my($record) = $_[2]; # Raw database row my($fieldnum); # Field number ### Use Field Name to find Field Number foreach (0..$#fields) { if ($fields[$_] eq $fieldname) { $fieldnum = $_; } } unless (defined $fieldnum) { die("DB_Field : Error, Couldn't find field name '$fieldname'\n"); } ### return decoded field from record return &DB_Decode((split(/\|/,$record))[$fieldnum]); }