← Back to branch summary

~ubuntu-branches/debian/sid/libembperl-perl/sid

« back to all changes in this revision

Viewing changes to eg/web/epwebapp.pl

  • Committer: Bazaar Package Importer
  • Author(s): Angus Lees
  • Date: 2004-02-15 14:23:39 UTC
  • Revision ID: james.westby@ubuntu.com-20040215142339-n21gqf7mx9tmyb8d
Tags: upstream-2.0b10
Import upstream version 2.0b10

Show diffs side-by-side

added added

removed removed

Lines of Context:
eg/web/epwebapp.pl
 
1
 
 
2
use Embperl::Recipe::XSLT ;
 
3
use Embperl::Recipe::Embperl  ;
 
4
use Embperl::Recipe::EmbperlXSLT  ;
 
5
use Embperl::Recipe::EmbperlPODXSLT  ;
 
6
use Embperl::Constant ;
 
7
 
 
8
use Data::Dumper ;
 
9
 
 
10
   
 
11
sub fill_menu 
 
12
 
 
13
    {
 
14
    my ($config, $item, $baseuri, $root, $parent) = @_ ;
 
15
 
 
16
    foreach $m (@$item)
 
17
        {
 
18
        $m -> {parent} ||= $parent ;
 
19
        $m -> {relurl}  ||= "$baseuri$m->{uri}" ;
 
20
        if (ref $m -> {path})
 
21
            {
 
22
            foreach my $k (keys %{$m -> {path}})
 
23
                { 
 
24
                if (($m -> {path}{$k} =~ /^\%(.*?)\%/))
 
25
                    {
 
26
                    if ($config -> {$1}) 
 
27
                        {
 
28
                        my $val = $config -> {$1} ;
 
29
                        $m -> {path}{$k} =~ s/^\%.*?\%/$val/ ; 
 
30
                        }
 
31
                    else
 
32
                        {
 
33
                        $m -> {path}{$k} = '' ;
 
34
                        }
 
35
                    }
 
36
                }
 
37
            }
 
38
        elsif ($m -> {path})
 
39
            {
 
40
            if (($m -> {path} =~ /^\%(.*?)\%/))
 
41
                {
 
42
                #warn "path=$m->{path}, 1=$1 c1=$config->{$1}" ;
 
43
                if ($config -> {$1}) 
 
44
                    {
 
45
                    my $val = $config -> {$1} ;
 
46
                    $m -> {path} =~ s/^\%.*?\%/$val/ ; 
 
47
                    }
 
48
                else
 
49
                    {
 
50
                    $m -> {path} = '' ;
 
51
                    }
 
52
                }
 
53
            }
 
54
        elsif (!$m -> {file} && !exists $m -> {path})
 
55
            {
 
56
            $m -> {path} = $root . $config -> {basepath} . $m -> {relurl} ;
 
57
            $m -> {path} .= 'index.htm' if ($m -> {path} =~ m#/$#) ;
 
58
            }
 
59
        elsif (ref $m -> {file})
 
60
            {
 
61
            $m -> {path} = { map { $_ => $root . $m->{file}{$_} } keys %{$m->{file}} } ;
 
62
            }
 
63
        elsif (!exists $m -> {path})
 
64
            {
 
65
            $m -> {path} = $root . $m->{file} ;
 
66
            $m -> {path} .= 'index.htm' if ($m -> {path} =~ m#/$#) ;
 
67
            }
 
68
        if ($m -> {path})
 
69
            {
 
70
            $config -> {map1}{$m -> {relurl}} = $m ;
 
71
            $config -> {map2}{$1} = $m if ($m  -> {relurl} =~ /^(.*)\./ );
 
72
            }
 
73
 
 
74
        my $subbase ;
 
75
        if ($m -> {relurl} !~ m#/$#)
 
76
            {
 
77
            $m -> {relurl} =~ /^(.*)\./ ;
 
78
            $subbase = "$1/" ;
 
79
            }
 
80
        else
 
81
            {
 
82
            $subbase = $m -> {relurl} ;
 
83
            }
 
84
 
 
85
        fill_menu ($config, $m -> {sub}, $subbase, $root, $m) if ($m -> {sub}) ;        
 
86
        fill_menu ($config, $m -> {same}, $baseuri, $root, $parent) if ($m -> {same}) ;        
 
87
        }
 
88
    }
 
89
 
 
90
#
 
91
# Add language to uri
 
92
#
 
93
 
 
94
sub languri
 
95
    {
 
96
    my ($self, $r, $uri, $lang) = @_ ;
 
97
 
 
98
    my $buri = $r->{config}{baseuri} ;
 
99
    $lang ||= $r -> {selected_language} ;
 
100
    $prefix = $r->{baseuri}  . ($r -> {selected_language}?'../':'') ;
 
101
    if ($lang && ($uri =~ /$buri(.*?)$/))
 
102
        {
 
103
        return "$prefix$lang/$1" ; 
 
104
        }
 
105
 
 
106
    return $uri ;
 
107
    }
 
108
 
 
109
 
 
110
 
 
111
sub map_file
 
112
    {
 
113
    my ($r, $uri) = @_ ;
 
114
    my $config = $r -> {config} ;
 
115
 
 
116
    # check if we have anything under this uri in our configuration
 
117
    #   if it's a directory, try to append index.*
 
118
    my $m ;
 
119
    $uri =~ /^(.*)\./ ;
 
120
    if (!($m = $config -> {map1}{$uri} || $config -> {map2}{$1}))
 
121
        {
 
122
        $m = $config -> {map1}{$1} if ($uri =~ m#^(.*?/)index\..*$#) ;
 
123
        }    
 
124
 
 
125
    # if we found something, setup $r -> {menuitem} to hold the menu
 
126
    # tree we need to display for this page
 
127
    if ($m && $m -> {path})
 
128
        {
 
129
        my @menuitems = ($m) ;
 
130
        my $item = $m ;
 
131
        while ($item = $item -> {parent})
 
132
            {
 
133
            unshift @menuitems, $item ;
 
134
            }
 
135
        $r -> {menuitems} = \@menuitems ;
 
136
        if ($m -> {fdat})
 
137
            {
 
138
            while (my ($k, $v) = each %{$m -> {fdat}}) 
 
139
                {
 
140
                $fdat{$k} = $v ;
 
141
                }
 
142
            }
 
143
 
 
144
        $r -> {curritem} = $m ;
 
145
        my $path = $m -> {path} ;
 
146
        if (ref $path)
 
147
            {
 
148
            return $path -> {$r -> param -> language} || $path -> {'en'} ;
 
149
            }
 
150
 
 
151
        return $path ;
 
152
        }
 
153
 
 
154
    # nothing found, so return a general error page
 
155
    return "$r->{config}{root}$r->{config}{basepath}notfound.htm" ;
 
156
    }
 
157
 
 
158
 
 
159
sub init 
 
160
    {
 
161
    my $self     = shift ;
 
162
    my $r        = shift ;
 
163
 
 
164
    my $config = Execute ({object => 'config.pl', syntax => 'Perl'}) ;
 
165
 
 
166
    $config -> new ($r) ;    
 
167
    
 
168
    $r -> {config} = $config  ;    
 
169
 
 
170
    my $uri = $r -> param -> uri ;
 
171
 
 
172
    # we embed some parameters in the uri itself, to allow making a
 
173
    # static copy, so see if there is anything here
 
174
    while ($uri =~ s/\.-(.*?)-(.*?)-\././g)
 
175
        {
 
176
        $fdat{$1} = $2 ;
 
177
        }
 
178
 
 
179
 
 
180
    # figure out necessary prefixes, so we can use relativ urls
 
181
    my @uri = split (/\//, $uri) ;
 
182
    push @uri, '' if ($uri =~ m#/$#) ;
 
183
    my $basedepth = $config->{basedepth} + 1 ;
 
184
    shift @uri while ($basedepth--) ;
 
185
    my $depth = $r -> {depth} = $#uri ;
 
186
 
 
187
    $r -> {imageuri} = ('../' x $depth) . $config -> {imageuri} ;
 
188
    $r -> {baseuri}  = ('../' x $depth)  ;
 
189
    # this is when creating static pages, to let actions point to the correct URL of the dynamic site
 
190
    $r -> {action_prefix} = $ENV{ACTION_PREFIX} || '' ; 
 
191
 
 
192
    my $langs  = $config -> {supported_languages} ;
 
193
    # serach the url, if there is a language embeded,
 
194
    # if yes remove it
 
195
    $r -> {selected_language} = '' ;
 
196
    my  $accept_lang = $r -> param -> language ;
 
197
    my  $lang_ok = 0 ;
 
198
    foreach (@$langs)
 
199
        {
 
200
        if ($uri[0] eq $_) 
 
201
            {
 
202
            $r -> param -> language($_) ;
 
203
            $r -> {selected_language} = $_ ;
 
204
            shift @uri ;
 
205
            $uri =~ s#/$_/#/# ;
 
206
            $r -> {baseuri}  = ('../' x ($depth - 1))  ; # we want to stay in the same language tree
 
207
            $lang_ok = 1 ;
 
208
            last ;
 
209
            }
 
210
        elsif ($accept_lang && $_ eq $accept_lang)
 
211
            {
 
212
            $lang_ok = 1 ;
 
213
            }
 
214
        }
 
215
 
 
216
    $r -> param -> uri ($uri) ;
 
217
    $r -> param -> language($langs -> [0]) if (!$r -> param -> language || !$lang_ok) ;
 
218
 
 
219
 
 
220
    #warn "2 d = $r->{depth} bd = $config->{basedepth}  #uri=$#uri  uri = @uri new uri = $uri" ;
 
221
 
 
222
    # get the menu data and create a tree structure out of it if not already done
 
223
    $r -> {menu}   = $config -> get_menu ($r) ;    
 
224
    fill_menu ($config, $r -> {menu}, '', $config -> {root}) ; ##if (!$config -> {map1}) ;
 
225
   
 
226
 
 
227
    # map the request uri to the real filename    
 
228
    $pf = map_file ($r, join ('/', @uri)) ;
 
229
    $r -> param -> filename ($pf) ;      # tell Embperl the filename
 
230
    $r -> apache_req -> filename ($pf) ; # tell Apache the filename
 
231
 
 
232
   
 
233
    #warn Dumper ($r -> {config}, $r -> param -> uri, $pf, \%fdat, $r -> config -> path) ;
 
234
    
 
235
    # read in the multi language messages 
 
236
    Execute ({inputfile => 'messages.pl', syntax => 'Perl'}) ;
 
237
 
 
238
    return 0 ;
 
239
    }
 
240
 
 
241
 
 
242
sub set_xslt_param
 
243
    {
 
244
    my ($class, $r, $config, $param) = @_ ;
 
245
 
 
246
    $config -> xsltstylesheet('pod.xsl') ;
 
247
    $r -> param -> uri =~ /^.*\/(.*)\.(.*?)$/ ;
 
248
    $param -> xsltparam({
 
249
            page      => $fdat{page} || 0, 
 
250
            basename  => "'$1'", 
 
251
            extension => "'$2'",
 
252
            imageuri  => "'$r->{imageuri}'",
 
253
            baseuri   => "'$r->{baseuri}'",
 
254
            language  => "'" . $r -> param -> language . "'" , 
 
255
            }) ;
 
256
    }
 
257
 
 
258
 
 
259
 
 
260
sub get_recipe
 
261
 
 
262
    {
 
263
    my ($class, $r, $recipe) = @_ ;
 
264
 
 
265
    my $self ;
 
266
    my $param  = $r -> component -> param  ;
 
267
    my $config = $r -> component -> config  ;
 
268
    my ($src)  = $param -> inputfile =~ /^.*\.(.*?)$/ ;
 
269
    my ($dest) = $r -> param -> uri =~ /^.*\.(.*?)$/ ;
 
270
 
 
271
   
 
272
 
 
273
    if ($src eq 'pl')
 
274
        {
 
275
        $config -> syntax('Perl') ;
 
276
        return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
 
277
        }
 
278
 
 
279
    if ($src eq 'pod' || $src eq 'pm')
 
280
        {
 
281
        $config -> escmode(0) ;
 
282
        if ($dest eq 'pod')
 
283
            {
 
284
            $config -> syntax('Text') ;
 
285
            return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
 
286
            }
 
287
 
 
288
        $config -> syntax('POD') ;
 
289
        if ($dest eq 'xml')
 
290
            {
 
291
            return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
 
292
            }
 
293
 
 
294
        $class -> set_xslt_param ($r, $config, $param) ;
 
295
        return Embperl::Recipe::EmbperlXSLT -> get_recipe ($r, $recipe) ;
 
296
        }
 
297
    
 
298
    if ($src eq 'xml')
 
299
        {
 
300
        $class -> set_xslt_param ($r, $config, $param) ;
 
301
        return Embperl::Recipe::EmbperlXSLT -> get_recipe ($r, $recipe) ;
 
302
        }
 
303
    
 
304
    if ($src eq 'epd')
 
305
        {
 
306
        $config -> escmode(0) ;
 
307
        $config -> options($config -> options | &Embperl::Constant::optKeepSpaces) ;
 
308
 
 
309
        if ($dest eq 'pod')
 
310
            {
 
311
            $config -> syntax('EmbperlBlocks') ;
 
312
            return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
 
313
            }
 
314
 
 
315
 
 
316
        $class -> set_xslt_param ($r, $config, $param) ;
 
317
        return Embperl::Recipe::EmbperlPODXSLT -> get_recipe ($r, $recipe) ;
 
318
        }
 
319
    
 
320
    if ($src eq 'epl' || $src eq 'htm')
 
321
        {
 
322
        $config -> syntax('Embperl') ;
 
323
        return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
 
324
        }
 
325
 
 
326
    if ($src eq 'mail')
 
327
        {
 
328
        $config -> syntax('EmbperlBlocks') ;
 
329
        return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
 
330
        }
 
331
 
 
332
 
 
333
    $config -> syntax('Text') ;
 
334
    return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
 
335
    }