libs/shortcuts/files.pm

## ---------------------------------------------------------------------------
##  $Id: files.pm,v 1.4 2003/05/13 09:23:03 joko Exp $
## ---------------------------------------------------------------------------
##  $Log: files.pm,v $
##  Revision 1.4  2003/05/13 09:23:03  joko
##  pre-flight checks for existance of base directory of to-be-executed script
##
##  Revision 1.3  2003/03/31 05:47:01  janosch
##  Mis mif gex
##
##  Revision 1.2  2003/02/20 21:12:24  joko
##  + prints to STDERR if logfile could not be opened
##
##  Revision 1.1  2003/02/11 09:50:00  joko
##  + code from Data::Storage::Handler::File::Basic
##
## ---------------------------------------------------------------------------

=pod

=head1  Background

   UNIX = Everything is a file
   Perl ~ Everything is a string   ;-)


=cut


package shortcuts::files;

use strict;
use warnings;

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw( 
  s2f
  a2f
  f2s
  rif
  mif
);


use Data::Dumper;
use File::Basename;

sub s2f {
  my $filename = shift;
  my $string = shift;
  my $args = shift;
  
  # pre-flight checks: Does directory exist?
  my $dirname = dirname($filename);
  if (not -e $dirname) {
    print STDERR __PACKAGE__ . ':' . __LINE__ . ": ERROR: Directory '$dirname' does not exist! (Write attempt)" . "\n";
    return;
  }

  # Perform: File write
  open(FH, '>' . $filename);
  if ($args->{mode} && $args->{mode} eq 'binary') {
    binmode(FH);
  }
  print FH $string;
  # Always inject ending newline? No, since it unneccessarily 
  # modifies files with absolutely *no* changes in content.
  print FH "\n" if $string !~ /\n$/;
  close(FH);
}

sub f2s {
  my $filename = shift;
  
  # pre-flight checks: Does file exist?
  if (! -e $filename) {
    print STDERR __PACKAGE__ . ':' . __LINE__ . ": ERROR: File '$filename' does not exist! (Read attempt)" . "\n";
    return;
  }
  
  # read file at once (be careful with big files!!!)
  open(FH, '<' . $filename);
  my @buf_arr = <FH>;
  my $buf = join("", @buf_arr);
  close(FH);
  return $buf;
}

sub a2f {
  my $filename = shift;
  my $string = shift;
  open(FH, '>>' . $filename) or do {
    print "Could not append to \"$filename\"!", "\n";
    print "Log-Message was: ";
    print $string if $string;
    print "\n";
    return;
  };
  #print FH "\n";
  print FH $string;
  print FH "\n";
  close(FH);
  return 1;
}

sub ris {
  my $string = shift;
  my $rules = shift;

  our $ris_result = 1;

  if (ref $rules eq 'HASH') {
    my @re_find = keys %{$rules};
    # replace all keys with substitutes from hash "%re_table"
    foreach my $find (@re_find) {
      my $replace = $rules->{$find};
      $ris_result &= ($string =~ s/$find/$replace/g);
    }
  }
  
  if (ref $rules eq 'ARRAY') {
    foreach my $rule (@{$rules}) {
      my $find    = $rule->[0];
      my $replace = $rule->[1];
      $ris_result &= ($string =~ s/$find/$replace/g);
    }
  }
  
  return $string;
}

sub rif {
  my $filename = shift;
  my $rules = shift;
  my $out_suffix = shift;

  my $outfile = $filename;
  $outfile .= '.' . $out_suffix if ($out_suffix);

  my $buf = f2s($filename);
  $buf = ris($buf, $rules);
  s2f($outfile, $buf);
}

sub mis {
  my $string = shift;
  my $rules = shift;

  my $mis_result = {};
  
  if (ref $rules eq 'HASH') {
    my @re_find = keys %{$rules};
    # replace all keys with substitutes from hash "%re_table"
    foreach my $find (@re_find) {
      #my $replace = $rules->{$find};
      #$mis_result &= ($string =~ m/$find/g);
      $mis_result->{$find} = ($string =~ m/$find/g);
      $mis_result->{$find} ||= 0;
    }
  }
  
  if (ref $rules eq 'ARRAY') {
    foreach my $rule (@{$rules}) {
      my $find    = (ref $rule eq 'ARRAY') ? $rule->[0] : $rule;
      $mis_result->{$find} = 0;
      my $pattern = quotemeta($find);
      $string =~ s{
        $pattern     # the pattern used to search through the whole file
      }{
        $mis_result->{$find}++;   # build result (increase counter per occourance)
      }gex;
    }
  }
  
  return $mis_result;
}

sub mif {
  my $filename = shift;
  my $rules = shift;
  my $out_suffix = shift;

  my $outfile = $filename;
  $outfile .= '.' . $out_suffix if ($out_suffix);

  my $buf = f2s($filename);
  return mis($buf, $rules);
  #s2f($outfile, $buf);
}

sub findKeyEntries {
  my $string = shift;
  my $pattern = shift;
  my @arr = split("\n", $string);
  my @entries;
  foreach (@arr) {
    chomp;
    #print "l: ", $_, "\n";
    if (m/$pattern/) {
      push @entries, $1;
    }
  }
  return \@entries;
}

# ---------------------------------
# is a context-entry in a file?
# a "context-entry" is an entry identified 
# by a certain keystring, which itself 
# is detected dynamically
sub isEntryInFile {

  my $chk = shift;
  my $content_current = f2s($chk->{filename});
  
  # try to find all key-entries via patterns which are "entry-identifiers"
  if (my @keys = @{ findKeyEntries($chk->{'out'}, $chk->{'pattern'}{'EntryIdent'}) }) {
    # iterate through all "entry-identifiers"
    foreach (@keys) {
      my $pattern = $chk->{'pattern'}{'EntryCheck'};
      $pattern =~ s/\@\@KEY\@\@/$_/;
      my $bool_AlreadyThere = ($content_current =~ m/$pattern/);
      if ($bool_AlreadyThere) {
        $chk->{'EntryFound'} = $_;
        return 1;
      }
    }
  }

}

1;
__END__
1	joko	1.1	## ---------------------------------------------------------------------------
2	joko	1.5	## $Id: files.pm,v 1.4 2003/05/13 09:23:03 joko Exp $
3	joko	1.1	## ---------------------------------------------------------------------------
4	joko	1.2	## $Log: files.pm,v $
5	joko	1.5	## Revision 1.4 2003/05/13 09:23:03 joko
6			## pre-flight checks for existance of base directory of to-be-executed script
7			##
8	joko	1.4	## Revision 1.3 2003/03/31 05:47:01 janosch
9			## Mis mif gex
10			##
11	janosch	1.3	## Revision 1.2 2003/02/20 21:12:24 joko
12			## + prints to STDERR if logfile could not be opened
13			##
14	joko	1.2	## Revision 1.1 2003/02/11 09:50:00 joko
15			## + code from Data::Storage::Handler::File::Basic
16			##
17	joko	1.1	## ---------------------------------------------------------------------------
18
19	janosch	1.3	=pod
20
21			=head1 Background
22
23			UNIX = Everything is a file
24			Perl ~ Everything is a string ;-)
25
26
27			=cut
28
29
30	joko	1.1
31			package shortcuts::files;
32
33			use strict;
34			use warnings;
35
36			require Exporter;
37			our @ISA = qw( Exporter );
38			our @EXPORT_OK = qw(
39			s2f
40			a2f
41			f2s
42	janosch	1.3	rif
43			mif
44	joko	1.1	);
45
46
47			use Data::Dumper;
48	joko	1.4	use File::Basename;
49	joko	1.1
50			sub s2f {
51			my $filename = shift;
52			my $string = shift;
53	joko	1.5	my $args = shift;
54	joko	1.4
55			# pre-flight checks: Does directory exist?
56			my $dirname = dirname($filename);
57			if (not -e $dirname) {
58			print STDERR __PACKAGE__ . ':' . __LINE__ . ": ERROR: Directory '$dirname' does not exist! (Write attempt)" . "\n";
59			return;
60			}
61
62			# Perform: File write
63	joko	1.1	open(FH, '>' . $filename);
64	joko	1.5	if ($args->{mode} && $args->{mode} eq 'binary') {
65			binmode(FH);
66			}
67	joko	1.1	print FH $string;
68	joko	1.5	# Always inject ending newline? No, since it unneccessarily
69			# modifies files with absolutely no changes in content.
70			print FH "\n" if $string !~ /\n$/;
71	joko	1.1	close(FH);
72			}
73
74			sub f2s {
75			my $filename = shift;
76	joko	1.4
77			# pre-flight checks: Does file exist?
78	joko	1.2	if (! -e $filename) {
79	joko	1.4	print STDERR __PACKAGE__ . ':' . __LINE__ . ": ERROR: File '$filename' does not exist! (Read attempt)" . "\n";
80	joko	1.2	return;
81			}
82	joko	1.4
83	joko	1.1	# read file at once (be careful with big files!!!)
84			open(FH, '<' . $filename);
85			my @buf_arr = <FH>;
86			my $buf = join("", @buf_arr);
87			close(FH);
88			return $buf;
89			}
90
91			sub a2f {
92			my $filename = shift;
93			my $string = shift;
94			open(FH, '>>' . $filename) or do {
95			print "Could not append to \"$filename\"!", "\n";
96			print "Log-Message was: ";
97			print $string if $string;
98			print "\n";
99			return;
100			};
101			#print FH "\n";
102			print FH $string;
103			print FH "\n";
104			close(FH);
105			return 1;
106			}
107
108			sub ris {
109			my $string = shift;
110			my $rules = shift;
111
112			our $ris_result = 1;
113
114			if (ref $rules eq 'HASH') {
115			my @re_find = keys %{$rules};
116			# replace all keys with substitutes from hash "%re_table"
117			foreach my $find (@re_find) {
118			my $replace = $rules->{$find};
119			$ris_result &= ($string =~ s/$find/$replace/g);
120			}
121			}
122
123			if (ref $rules eq 'ARRAY') {
124			foreach my $rule (@{$rules}) {
125			my $find = $rule->[0];
126			my $replace = $rule->[1];
127			$ris_result &= ($string =~ s/$find/$replace/g);
128			}
129			}
130
131			return $string;
132			}
133
134			sub rif {
135			my $filename = shift;
136			my $rules = shift;
137			my $out_suffix = shift;
138
139			my $outfile = $filename;
140			$outfile .= '.' . $out_suffix if ($out_suffix);
141
142			my $buf = f2s($filename);
143			$buf = ris($buf, $rules);
144			s2f($outfile, $buf);
145	janosch	1.3	}
146
147			sub mis {
148			my $string = shift;
149			my $rules = shift;
150
151			my $mis_result = {};
152
153			if (ref $rules eq 'HASH') {
154			my @re_find = keys %{$rules};
155			# replace all keys with substitutes from hash "%re_table"
156			foreach my $find (@re_find) {
157			#my $replace = $rules->{$find};
158			#$mis_result &= ($string =~ m/$find/g);
159			$mis_result->{$find} = ($string =~ m/$find/g);
160			$mis_result->{$find} \|\|= 0;
161			}
162			}
163
164			if (ref $rules eq 'ARRAY') {
165			foreach my $rule (@{$rules}) {
166			my $find = (ref $rule eq 'ARRAY') ? $rule->[0] : $rule;
167			$mis_result->{$find} = 0;
168			my $pattern = quotemeta($find);
169			$string =~ s{
170			$pattern # the pattern used to search through the whole file
171			}{
172			$mis_result->{$find}++; # build result (increase counter per occourance)
173			}gex;
174			}
175			}
176
177			return $mis_result;
178			}
179
180			sub mif {
181			my $filename = shift;
182			my $rules = shift;
183			my $out_suffix = shift;
184
185			my $outfile = $filename;
186			$outfile .= '.' . $out_suffix if ($out_suffix);
187
188			my $buf = f2s($filename);
189			return mis($buf, $rules);
190			#s2f($outfile, $buf);
191	joko	1.1	}
192
193			sub findKeyEntries {
194			my $string = shift;
195			my $pattern = shift;
196			my @arr = split("\n", $string);
197			my @entries;
198			foreach (@arr) {
199			chomp;
200			#print "l: ", $_, "\n";
201			if (m/$pattern/) {
202			push @entries, $1;
203			}
204			}
205			return \@entries;
206			}
207
208			# ---------------------------------
209			# is a context-entry in a file?
210			# a "context-entry" is an entry identified
211			# by a certain keystring, which itself
212			# is detected dynamically
213			sub isEntryInFile {
214
215			my $chk = shift;
216			my $content_current = f2s($chk->{filename});
217
218			# try to find all key-entries via patterns which are "entry-identifiers"
219			if (my @keys = @{ findKeyEntries($chk->{'out'}, $chk->{'pattern'}{'EntryIdent'}) }) {
220			# iterate through all "entry-identifiers"
221			foreach (@keys) {
222			my $pattern = $chk->{'pattern'}{'EntryCheck'};
223			$pattern =~ s/\@\@KEY\@\@/$_/;
224			my $bool_AlreadyThere = ($content_current =~ m/$pattern/);
225			if ($bool_AlreadyThere) {
226			$chk->{'EntryFound'} = $_;
227			return 1;
228			}
229			}
230			}
231
232			}
233
234			1;
235			__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26