/[cvs]/nfo/perl/libs/libp.pm
ViewVC logotype

Diff of /nfo/perl/libs/libp.pm

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

revision 1.12 by joko, Sun Dec 22 14:15:02 2002 UTC revision 1.14 by joko, Sun Feb 9 04:49:09 2003 UTC
# Line 3  Line 3 
3  #  $Id$  #  $Id$
4  #  #
5  #  $Log$  #  $Log$
6    #  Revision 1.14  2003/02/09 04:49:09  joko
7    #  - purged lots of code and refactored into other modules
8    #  - sorry!
9    #
10    #  Revision 1.13  2002/12/23 04:25:13  joko
11    #  + sub bool2status
12    #
13  #  Revision 1.12  2002/12/22 14:15:02  joko  #  Revision 1.12  2002/12/22 14:15:02  joko
14  #  + sub mkObject  #  + sub mkObject
15  #  #
# Line 52  use warnings; Line 59  use warnings;
59  require Exporter;  require Exporter;
60  our @ISA = qw( Exporter );  our @ISA = qw( Exporter );
61  our @EXPORT_OK = qw(  our @EXPORT_OK = qw(
     Dumper  
     md5 md5_hex md5_base64  
62      ParseDate UnixDate      ParseDate UnixDate
     strftime  
     croak  
   
     stripHtml stripSpaces stripNewLines toReal trim  
63      array_getDifference      array_getDifference
64      getDirList      bool2status
     now today  
     deep_copy  
     getNewPerlObjectByPkgName  
     run_cmd run_cmds  
     mkObject  
65  );  );
66    
 use Data::Dumper;  
 use Digest::MD5 qw(md5 md5_hex md5_base64);  
   
67  $main::TZ = 'GMT';  $main::TZ = 'GMT';
68  use Date::Manip;  use Date::Manip;
69    
 require LWP::UserAgent;  
 use HTML::PullParser;  
   
 # $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime;  
 # see "perldoc -f localtime"  
 use POSIX qw(strftime);  
   
 use Carp;  
   
 use DirHandle;  
   
70    
71  ########################################  ########################################
72    
 sub stripSpaces {  
   my $text = shift;  
   #print "text: $text", "\n";  
   #print "ord: ", ord(substr($text, 0, 1)), "\n";  
   $text =~ s/^\s*//g;  
   $text =~ s/\s*$//g;  
   return $text;  
 }  
   
 sub trim {  
   my $string = shift;  
   return stripSpaces($string);  
 }  
   
 sub stripNewLines {  
   my $text = shift;  
   #print "text: $text", "\n";  
   #print "ord: ", ord(substr($text, 0, 1)), "\n";  
   $text =~ s/\n//g;  
   #$text =~ s/\s*$//g;  
   return $text;  
 }  
   
 sub toReal {  
   my $string = shift;  
   $string =~ m/(\d+\.*\d+)/;  
   my $real = $1;  
   return $real;  
 }  
   
 sub stripHtml {  
   my $html = shift;  
   my $result = '';  
   #$html =~ s/<br>(.*)/ - ($1)/i;  
   my $p = HTML::PullParser->new(  
     doc => \$html,  
     text => 'text',  
     unbroken_text => 1,  
   );  
   while (my $token = $p->get_token()) {  
     my $text = join('', @{$token});  
     $result .= $text;  
   }  
   #$result =~ s/&nbsp;//g;  
   return $result;  
 }  
   
   
   
   
 # =============================================  
 # "global" vars used in directory-recursive-parsing  
 my $dirlist_buf;  
 my @dirlist_path;  
 my $dirlist_base;  
   
 sub entry_callback {  
   
   my $entry = shift;  
   
   # CHECKS  
   # dont't use this:  
   if ($entry eq '.' || $entry eq '..') { return; }  
   
   # PREPARE  
   # prepare path to current entry  
   my $cur_entry = join('/', @dirlist_path, $entry);  
   # prepare path to current entry (absolute)  
   my $cur_entry_abs = join('/', $dirlist_base, @dirlist_path, $entry);  
   
   # ENTRY  
   # add current entry to buffer  
   $dirlist_buf .= $cur_entry . "\n";  
   
   # (SUB-)DIRECTORY  
   # check if current entry is a (sub-)directory ...  
   if (-d $cur_entry_abs) {  
     push @dirlist_path, $cur_entry;  
     # ... and parse this (recursion here!!!)  
     iterate_path($cur_entry_abs);  
     pop @dirlist_path;  
   }  
 }  
   
 sub iterate_path {  
   
   my $path = shift;  
73    
   # create new "DirHandle"-object  
   my $d = new DirHandle $path;  
   if (defined $d) {  
   
     # iterate through all entries in $path ($d->read) and call out entry-handler on each entry  
     while (defined(my $line = $d->read)) {  
       entry_callback($line);  
     }  
   
     undef $d;  
   }  
 }  
74    
 sub getDirList {  
75    
   $dirlist_base = shift;  
76    
   # reset vars  
   $dirlist_buf = '';  
   @dirlist_path = ();  
   
   # start parsing file-structure  
   iterate_path($dirlist_base);  
   
   # return complete list of directory-content including files and subdirs  
   # entries are newline (\n) - seperated  
   return $dirlist_buf;  
   
 }  
77  # =============================================  # =============================================
78    
79    
80  sub now {  sub bool2status {
81    return strftime("%Y-%m-%d %H:%M:%S", localtime);    my $bool = shift;
82  }    return ($bool ? 'ok' : 'failed');
   
 sub today {  
   return strftime("%Y-%m-%d", localtime);  
 }  
   
 # ACK's go to ...  
 sub deep_copy {  
   my $this = shift;  
   if (not ref $this) {  
     $this;  
   } elsif (ref $this eq "ARRAY") {  
     [map deep_copy($_), @$this];  
   } elsif (ref $this eq "HASH") {  
     +{map { $_ => deep_copy($this->{$_}) } keys %$this};  
   } elsif (ref $this eq "CODE") {  
     $this;  
   #} else { die "deep_copy asks: what type is $this?" }  
   } else { print "deep_copy asks: what type is $this?", "\n"; }  
 }  
   
 sub getNewPerlObjectByPkgName {  
   my $pkgname = shift;  
   my $args = shift;  
   #$logger->debug( __PACKAGE__ . "->getNewPerlObjectByPkgName( pkgname $pkgname args $args )" );  
   my $evstring = "use $pkgname;";  
   eval($evstring);  
   #$@ && $logger->error( __PACKAGE__ . ':' . __LINE__ . " Error in eval $evstring: " .  $@ );  
   $@ && print( __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " .  $@ );  
   return $pkgname->new($args);  
 }  
   
 sub mkObject {  
   my $pkgname = shift;  
   #my $args = shift;  
   #$logger->debug( __PACKAGE__ . "->getNewPerlObjectByPkgName( pkgname $pkgname args $args )" );  
   my $evstring = "use $pkgname;";  
   eval($evstring);  
   #$@ && $logger->error( __PACKAGE__ . ':' . __LINE__ . " Error in eval $evstring: " .  $@ );  
   $@ && print( __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " .  $@ );  
   return $pkgname->new(@_);  
 }  
   
 sub run_cmd {  
   my $cmd = shift;  
   $cmd = 'perl ' . $cmd;  
   my $sep = "-" x 90;  
   print $sep, "\n";  
   print "  ", $cmd, "\n";  
   print $sep, "\n";  
   system($cmd);  
   print "\n";  
 }  
   
 sub run_cmds {  
   foreach (@_) {  
     run_cmd($_);  
   }  
83  }  }
84    
85  1;  1;
Legend:
Removed from v.1.12  
changed lines
  Added in v.1.14
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed