WAIT/Document/Ora.pm

#                              -*- Mode: Cperl -*- 
# Nroff.pm -- 
# ITIID           : $ITI$ $Header $__Header$
# Author          : Ulrich Pfeifer
# Created On      : Mon Sep 16 19:04:37 1996
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Fri Jan  4 15:56:11 2002
# Language        : CPerl
# Update Count    : 86
# Status          : Unknown, Use with caution!
# 
# Copyright (c) 1996-1997, Ulrich Pfeifer
# 

package WAIT::Document::Ora;
@ISA = qw(WAIT::Document::Base);
use WAIT::Document::Base;

use IO::File;
use Encode;
use strict;
use Carp;

sub TIEHASH {
  my $type    = shift;
  my $dir     = shift;
  my @files;

  opendir(DIR, $dir) or croak "Could not open '$dir': $!";
 DIRENT: for my $entry (readdir DIR) {
    if (-f "$dir/$entry/desc.html") {
      my $index = "$dir/$entry/index.html";
      open F, $index or Carp::confess("Could not open $index: $!");
      local $/;
      my $content = <F>;
      next DIRENT unless $content =~ m|<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"\s+"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\s+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">\s+<head>\s+<!-- product id:|s;
      push @files, $entry;
    }
  }
  closedir DIR;
  my $self   = {
                Dir    => $dir,
                Files  => \@files
               };
  bless $self, ref($type) || $type;
}

sub FETCH {
  my $self = shift;
  my $file = shift;

  local($/) = undef;

  my $fh = IO::File->new(join('/',$self->{Dir},$file,'desc.html'));
  my $desc = conv_getline($fh);
  $fh = IO::File->new(join('/',$self->{Dir},$file,'author.html'));
  my $author = conv_getline($fh) if $fh;
  $fh = IO::File->new(join('/',$self->{Dir},$file,'index.html'));
  my $index = conv_getline($fh) if $fh;
  $fh = IO::File->new(join('/',$self->{Dir},$file,'colophon.html'));
  my $colophon = conv_getline($fh) if $fh;
  return {
          desc => $desc,
          author => $author,
          index => $index,
          colophon => $colophon,
         };
}

# WAIT::Document::Ora::conv_getline
sub conv_getline ($) {
  my($fh) = shift;
  local $/ = "\n";
  my $firstline = <$fh>;
  my $src_enc;
  # \042 is double quote, \047 is single quote. I avoid single quotes
  # here just for easier copy and paste to the terminal (I need to
  # debug here frequently)
  if ($firstline =~ /<\?xml[^>]+encoding\s*=([\042\047])([\w\-]+)\1/) {
    $src_enc = $2;
  } else {
    $src_enc = "ISO-8859-1";
  }
  seek $fh, 0, 0;
  undef $/;
  my $content = <$fh>;
  $content =~ s/\s+/ /gs; # eliminate TABs and CRs for easier debugging
  my $dcontent = Encode::decode($src_enc,$content);
  $dcontent;
}

sub FIRSTKEY {
  my $self = shift;
  $self->{fno} = 0;
  $self->NEXTKEY;
}

sub NEXTKEY {
  my $self = shift;
  return undef if ($self->{fno}++ > @{$self->{Files}});
  $self->{Files}->[$self->{fno}-1];
}

sub close {
  my $self = shift;

  delete $self->{fno};
  delete $self->{Files};        # no need at query time
}

1;
1	ulpfr	53	# -- Mode: Cperl --
2			# Nroff.pm --
3			# ITIID : $ITI$ $Header $__Header$
4			# Author : Ulrich Pfeifer
5			# Created On : Mon Sep 16 19:04:37 1996
6			# Last Modified By: Ulrich Pfeifer
7	ulpfr	60	# Last Modified On: Fri Jan 4 15:56:11 2002
8	ulpfr	53	# Language : CPerl
9	ulpfr	60	# Update Count : 86
10	ulpfr	53	# Status : Unknown, Use with caution!
11			#
12			# Copyright (c) 1996-1997, Ulrich Pfeifer
13			#
14
15			package WAIT::Document::Ora;
16			@ISA = qw(WAIT::Document::Base);
17	laperla	69	use WAIT::Document::Base;
18	ulpfr	53
19			use IO::File;
20	laperla	69	use Encode;
21	ulpfr	53	use strict;
22			use Carp;
23
24			sub TIEHASH {
25			my $type = shift;
26			my $dir = shift;
27			my @files;
28
29			opendir(DIR, $dir) or croak "Could not open '$dir': $!";
30	laperla	65	DIRENT: for my $entry (readdir DIR) {
31	ulpfr	53	if (-f "$dir/$entry/desc.html") {
32	laperla	65	my $index = "$dir/$entry/index.html";
33			open F, $index or Carp::confess("Could not open $index: $!");
34			local $/;
35			my $content = <F>;
36			next DIRENT unless $content =~ m\|<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"\s+"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\s+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">\s+<head>\s+<!-- product id:\|s;
37	ulpfr	53	push @files, $entry;
38			}
39			}
40	laperla	65	closedir DIR;
41	ulpfr	53	my $self = {
42			Dir => $dir,
43			Files => \@files
44			};
45			bless $self, ref($type) \|\| $type;
46			}
47
48			sub FETCH {
49			my $self = shift;
50			my $file = shift;
51
52			local($/) = undef;
53
54			my $fh = IO::File->new(join('/',$self->{Dir},$file,'desc.html'));
55	laperla	69	my $desc = conv_getline($fh);
56	ulpfr	53	$fh = IO::File->new(join('/',$self->{Dir},$file,'author.html'));
57	laperla	69	my $author = conv_getline($fh) if $fh;
58	ulpfr	60	$fh = IO::File->new(join('/',$self->{Dir},$file,'index.html'));
59	laperla	69	my $index = conv_getline($fh) if $fh;
60	laperla	65	$fh = IO::File->new(join('/',$self->{Dir},$file,'colophon.html'));
61	laperla	69	my $colophon = conv_getline($fh) if $fh;
62	laperla	65	return {
63			desc => $desc,
64			author => $author,
65			index => $index,
66			colophon => $colophon,
67			};
68	ulpfr	53	}
69
70	laperla	69	# WAIT::Document::Ora::conv_getline
71			sub conv_getline ($) {
72			my($fh) = shift;
73			local $/ = "\n";
74			my $firstline = <$fh>;
75			my $src_enc;
76			# \042 is double quote, \047 is single quote. I avoid single quotes
77			# here just for easier copy and paste to the terminal (I need to
78			# debug here frequently)
79			if ($firstline =~ /<\?xml[^>]+encoding\s*=([\042\047])([\w\-]+)\1/) {
80			$src_enc = $2;
81			} else {
82			$src_enc = "ISO-8859-1";
83			}
84			seek $fh, 0, 0;
85			undef $/;
86			my $content = <$fh>;
87			$content =~ s/\s+/ /gs; # eliminate TABs and CRs for easier debugging
88			my $dcontent = Encode::decode($src_enc,$content);
89			$dcontent;
90			}
91
92	ulpfr	53	sub FIRSTKEY {
93			my $self = shift;
94			$self->{fno} = 0;
95			$self->NEXTKEY;
96			}
97
98			sub NEXTKEY {
99			my $self = shift;
100			return undef if ($self->{fno}++ > @{$self->{Files}});
101			$self->{Files}->[$self->{fno}-1];
102			}
103
104			sub close {
105			my $self = shift;
106
107			delete $self->{fno};
108			delete $self->{Files}; # no need at query time
109			}
110
111			1;