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