tags/0.4.3.1-pre2/SrSv/Help.pm

   1 #       This file is part of SurrealServices.
   2 #
   3 #       SurrealServices is free software; you can redistribute it and/or modify
   4 #       it under the terms of the GNU General Public License as published by
   5 #       the Free Software Foundation; either version 2 of the License, or
   6 #       (at your option) any later version.
   7 #
   8 #       SurrealServices is distributed in the hope that it will be useful,
   9 #       but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 #       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 #       GNU General Public License for more details.
  12 #
  13 #       You should have received a copy of the GNU General Public License
  14 #       along with SurrealServices; if not, write to the Free Software
  15 #       Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16 package SrSv::Help;
  17 use strict;
  18
  19 use SrSv::User::Notice qw( notice );
  20
  21 use Exporter 'import';
  22 BEGIN {
  23         our @EXPORT = qw( sendhelp readhelp );
  24         my %constants = ( HELP_PATH => main::PREFIX()."/help/" );
  25         require constant; import constant \%constants;
  26 }
  27
  28 sub readhelp($) {
  29         my ($file_name) = @_;
  30         my @array;
  31
  32         open ((my $file_handle), $file_name) or return undef();
  33
  34         while(my $x = <$file_handle>) {
  35                 next if $x =~ /^#/;
  36                 chomp $x;
  37                 $x =~ s/\%B/\002/g;
  38                 $x =~ s/\%U/\037/g; # chr(31)
  39                 $x =~ s/\%E(.*?)\%E/eval($1)/eg;
  40
  41                 $x = ' ' if $x eq '';
  42                 push @array, $x;
  43         }
  44
  45         close $file_handle;
  46
  47         return (' ', @array, ' --');
  48 }
  49
  50 sub sendhelp($@) {
  51         my ($user, @subject) = @_;
  52
  53         @subject = split(/ /, $subject[0]) if(@subject == 1);
  54
  55         # change any / or . to _
  56         # this is to prevent ppl from using this to access
  57         # files outside of the helpdir.
  58         # also lowercase the @subject components
  59         foreach my $s (@subject) {
  60                 $s = lc $s;
  61                 $s =~ s/[^a-z0-9\-]/_/g;
  62         }
  63
  64         my $file = HELP_PATH . join('/', @subject) . '.txt';
  65         my @array = readhelp($file);
  66         unless($array[0]) {
  67             notice($user, "No help for \002".join(' ',
  68                         @subject)."\002");
  69             return;
  70         }
  71
  72         notice($user, @array);
  73 }
  74
  75 1;