perl/libs/libp.pm

#################################
#
#  $Id: libp.pm,v 1.12 2002/12/22 14:15:02 joko Exp $
#
#  $Log: libp.pm,v $
#  Revision 1.12  2002/12/22 14:15:02  joko
#  + sub mkObject
#
#  Revision 1.11  2002/12/19 16:27:17  joko
#  +- renamed 'cmd' to 'run_cmd'
#
#  Revision 1.10  2002/12/19 01:05:35  joko
#  + sub today
#
#  Revision 1.9  2002/12/05 13:54:00  joko
#  + fix: let 'deep_copy' print its message out (instead of die)
#
#  Revision 1.8  2002/12/01 22:11:35  joko
#  + sub cmd
#  + sub run_cmds
#
#  Revision 1.7  2002/11/29 04:44:53  joko
#  - sub array_getRelations
#  + sub getNewPerlObjectByPkgName
#
#  Revision 1.6  2002/11/17 07:18:59  joko
#  + sub deep_copy
#
#  Revision 1.5  2002/10/27 18:34:28  joko
#  + sub now
#
#  Revision 1.4  2002/08/16 19:06:39  cvsjoko
#  + sub getDirList
#
#  Revision 1.3  2002/07/19 18:13:50  cvsjoko
#  no message
#
#  Revision 1.2  2002/06/27 02:14:22  cvsjoko
#  + stripHtml stripSpaces stripNewLines toReal
#
#  Revision 1.1  2002/06/24 14:49:59  cvsjoko
#  + new
#
#
#################################

package libp;

use strict;
use warnings;

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw( 
    Dumper
    md5 md5_hex md5_base64
    ParseDate UnixDate
    strftime
    croak

    stripHtml stripSpaces stripNewLines toReal trim
    array_getDifference
    getDirList
    now today
    deep_copy
    getNewPerlObjectByPkgName
    run_cmd run_cmds
    mkObject
    bool2status
);

use Data::Dumper;
use Digest::MD5 qw(md5 md5_hex md5_base64);

$main::TZ = 'GMT';
use Date::Manip;

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;


########################################

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;

  # 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;
  }
}

sub getDirList {

  $dirlist_base = shift;

  # 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;

}
# =============================================


sub now {
  return strftime("%Y-%m-%d %H:%M:%S", localtime);
}

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($_);
  }
}

sub bool2status {
  my $bool = shift;
  return ($bool ? 'ok' : 'failed');
}

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