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