/[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.1 by cvsjoko, Mon Jun 24 14:49:59 2002 UTC revision 1.13 by joko, Mon Dec 23 04:25:13 2002 UTC
# Line 3  Line 3 
3  #  $Id$  #  $Id$
4  #  #
5  #  $Log$  #  $Log$
6    #  Revision 1.13  2002/12/23 04:25:13  joko
7    #  + sub bool2status
8    #
9    #  Revision 1.12  2002/12/22 14:15:02  joko
10    #  + sub mkObject
11    #
12    #  Revision 1.11  2002/12/19 16:27:17  joko
13    #  +- renamed 'cmd' to 'run_cmd'
14    #
15    #  Revision 1.10  2002/12/19 01:05:35  joko
16    #  + sub today
17    #
18    #  Revision 1.9  2002/12/05 13:54:00  joko
19    #  + fix: let 'deep_copy' print its message out (instead of die)
20    #
21    #  Revision 1.8  2002/12/01 22:11:35  joko
22    #  + sub cmd
23    #  + sub run_cmds
24    #
25    #  Revision 1.7  2002/11/29 04:44:53  joko
26    #  - sub array_getRelations
27    #  + sub getNewPerlObjectByPkgName
28    #
29    #  Revision 1.6  2002/11/17 07:18:59  joko
30    #  + sub deep_copy
31    #
32    #  Revision 1.5  2002/10/27 18:34:28  joko
33    #  + sub now
34    #
35    #  Revision 1.4  2002/08/16 19:06:39  cvsjoko
36    #  + sub getDirList
37    #
38    #  Revision 1.3  2002/07/19 18:13:50  cvsjoko
39    #  no message
40    #
41    #  Revision 1.2  2002/06/27 02:14:22  cvsjoko
42    #  + stripHtml stripSpaces stripNewLines toReal
43    #
44  #  Revision 1.1  2002/06/24 14:49:59  cvsjoko  #  Revision 1.1  2002/06/24 14:49:59  cvsjoko
45  #  + new  #  + new
46  #  #
# Line 11  Line 49 
49    
50  package libp;  package libp;
51    
 require Exporter;  
 @ISA = qw( Exporter );  
 @EXPORT = qw(  
   Dumper  
   md5 md5_hex md5_base64  
   ParseDate UnixDate  
 );  
   
52  use strict;  use strict;
53  use warnings;  use warnings;
54    
55    require Exporter;
56    our @ISA = qw( Exporter );
57    our @EXPORT_OK = qw(
58        Dumper
59        md5 md5_hex md5_base64
60        ParseDate UnixDate
61        strftime
62        croak
63    
64        stripHtml stripSpaces stripNewLines toReal trim
65        array_getDifference
66        getDirList
67        now today
68        deep_copy
69        getNewPerlObjectByPkgName
70        run_cmd run_cmds
71        mkObject
72        bool2status
73    );
74    
75  use Data::Dumper;  use Data::Dumper;
76  use Digest::MD5 qw(md5 md5_hex md5_base64);  use Digest::MD5 qw(md5 md5_hex md5_base64);
77    
78  $main::TZ = 'GMT';  $main::TZ = 'GMT';
79  use Date::Manip;  use Date::Manip;
80    
81    require LWP::UserAgent;
82    use HTML::PullParser;
83    
84    # $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime;
85    # see "perldoc -f localtime"
86    use POSIX qw(strftime);
87    
88    use Carp;
89    
90    use DirHandle;
91    
92    
93    ########################################
94    
95    sub stripSpaces {
96      my $text = shift;
97      #print "text: $text", "\n";
98      #print "ord: ", ord(substr($text, 0, 1)), "\n";
99      $text =~ s/^\s*//g;
100      $text =~ s/\s*$//g;
101      return $text;
102    }
103    
104    sub trim {
105      my $string = shift;
106      return stripSpaces($string);
107    }
108    
109    sub stripNewLines {
110      my $text = shift;
111      #print "text: $text", "\n";
112      #print "ord: ", ord(substr($text, 0, 1)), "\n";
113      $text =~ s/\n//g;
114      #$text =~ s/\s*$//g;
115      return $text;
116    }
117    
118    sub toReal {
119      my $string = shift;
120      $string =~ m/(\d+\.*\d+)/;
121      my $real = $1;
122      return $real;
123    }
124    
125    sub stripHtml {
126      my $html = shift;
127      my $result = '';
128      #$html =~ s/<br>(.*)/ - ($1)/i;
129      my $p = HTML::PullParser->new(
130        doc => \$html,
131        text => 'text',
132        unbroken_text => 1,
133      );
134      while (my $token = $p->get_token()) {
135        my $text = join('', @{$token});
136        $result .= $text;
137      }
138      #$result =~ s/&nbsp;//g;
139      return $result;
140    }
141    
142    
143    
144    
145    # =============================================
146    # "global" vars used in directory-recursive-parsing
147    my $dirlist_buf;
148    my @dirlist_path;
149    my $dirlist_base;
150    
151    sub entry_callback {
152    
153      my $entry = shift;
154    
155      # CHECKS
156      # dont't use this:
157      if ($entry eq '.' || $entry eq '..') { return; }
158    
159      # PREPARE
160      # prepare path to current entry
161      my $cur_entry = join('/', @dirlist_path, $entry);
162      # prepare path to current entry (absolute)
163      my $cur_entry_abs = join('/', $dirlist_base, @dirlist_path, $entry);
164    
165      # ENTRY
166      # add current entry to buffer
167      $dirlist_buf .= $cur_entry . "\n";
168    
169      # (SUB-)DIRECTORY
170      # check if current entry is a (sub-)directory ...
171      if (-d $cur_entry_abs) {
172        push @dirlist_path, $cur_entry;
173        # ... and parse this (recursion here!!!)
174        iterate_path($cur_entry_abs);
175        pop @dirlist_path;
176      }
177    }
178    
179    sub iterate_path {
180    
181      my $path = shift;
182    
183      # create new "DirHandle"-object
184      my $d = new DirHandle $path;
185      if (defined $d) {
186    
187        # iterate through all entries in $path ($d->read) and call out entry-handler on each entry
188        while (defined(my $line = $d->read)) {
189          entry_callback($line);
190        }
191    
192        undef $d;
193      }
194    }
195    
196    sub getDirList {
197    
198      $dirlist_base = shift;
199    
200      # reset vars
201      $dirlist_buf = '';
202      @dirlist_path = ();
203    
204      # start parsing file-structure
205      iterate_path($dirlist_base);
206    
207      # return complete list of directory-content including files and subdirs
208      # entries are newline (\n) - seperated
209      return $dirlist_buf;
210    
211    }
212    # =============================================
213    
214    
215    sub now {
216      return strftime("%Y-%m-%d %H:%M:%S", localtime);
217    }
218    
219    sub today {
220      return strftime("%Y-%m-%d", localtime);
221    }
222    
223    # ACK's go to ...
224    sub deep_copy {
225      my $this = shift;
226      if (not ref $this) {
227        $this;
228      } elsif (ref $this eq "ARRAY") {
229        [map deep_copy($_), @$this];
230      } elsif (ref $this eq "HASH") {
231        +{map { $_ => deep_copy($this->{$_}) } keys %$this};
232      } elsif (ref $this eq "CODE") {
233        $this;
234      #} else { die "deep_copy asks: what type is $this?" }
235      } else { print "deep_copy asks: what type is $this?", "\n"; }
236    }
237    
238    sub getNewPerlObjectByPkgName {
239      my $pkgname = shift;
240      my $args = shift;
241      #$logger->debug( __PACKAGE__ . "->getNewPerlObjectByPkgName( pkgname $pkgname args $args )" );
242      my $evstring = "use $pkgname;";
243      eval($evstring);
244      #$@ && $logger->error( __PACKAGE__ . ':' . __LINE__ . " Error in eval $evstring: " .  $@ );
245      $@ && print( __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " .  $@ );
246      return $pkgname->new($args);
247    }
248    
249    sub mkObject {
250      my $pkgname = shift;
251      #my $args = shift;
252      #$logger->debug( __PACKAGE__ . "->getNewPerlObjectByPkgName( pkgname $pkgname args $args )" );
253      my $evstring = "use $pkgname;";
254      eval($evstring);
255      #$@ && $logger->error( __PACKAGE__ . ':' . __LINE__ . " Error in eval $evstring: " .  $@ );
256      $@ && print( __PACKAGE__ . ':' . __LINE__ . " Error in eval \"$evstring\": " .  $@ );
257      return $pkgname->new(@_);
258    }
259    
260    sub run_cmd {
261      my $cmd = shift;
262      $cmd = 'perl ' . $cmd;
263      my $sep = "-" x 90;
264      print $sep, "\n";
265      print "  ", $cmd, "\n";
266      print $sep, "\n";
267      system($cmd);
268      print "\n";
269    }
270    
271    sub run_cmds {
272      foreach (@_) {
273        run_cmd($_);
274      }
275    }
276    
277    sub bool2status {
278      my $bool = shift;
279      return ($bool ? 'ok' : 'failed');
280    }
281    
282  1;  1;
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.13
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed