← Back to branch summary

~ubuntu-branches/ubuntu/precise/padre/precise

« back to all changes in this revision

Viewing changes to xt/mimetype.t

  • Committer: Bazaar Package Importer
  • Author(s): Damyan Ivanov
  • Date: 2010-05-08 09:17:22 UTC
  • mfrom: (1.2.1 upstream) (10.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20100508091722-y6008jtk0ap6znyn
Tags: 0.60.ds1-3
http://bugs.debian.org/579289
rules: run tests with HOME=$fake_home to avoud failing when $HOME points
to a non-existent location. Closes: #579289

Show diffs side-by-side

added added

removed removed

Lines of Context:
xt/mimetype.t
 
1
#!/usr/bin/perl
 
2
 
 
3
use strict;
 
4
use warnings;
 
5
use Test::More;
 
6
use File::Find::Rule;
 
7
 
 
8
my %test_texts = (
 
9
        ".class { border: 1px solid; } a { text-decoration: none; }"              => 'text/css',
 
10
        '[% PROCESS Padre %]'                                                     => 'text/x-perltt',
 
11
        '#!/bin/bash'                                                             => 'application/x-shellscript',
 
12
        '<html><head><title>Padre</title></head></html>'                          => 'text/html',
 
13
        '=begin pod'                                                              => 'application/x-perl6',
 
14
        'use v6;'                                                                 => 'application/x-perl6',
 
15
        'use strict; sub foo { 1; } my $self = split(/y/,$ENV{foo}));'            => 'application/x-perl',
 
16
        "function lua_fct()\n\t--[[This\n\tis\n\ta\ncomment\n\t]]--repeat\nend\n" => 'text/x-lua',
 
17
);
 
18
 
 
19
my %test_files = (
 
20
        'foo.pl'     => 'application/x-perl',
 
21
        'bar.p6'     => 'application/x-perl6',
 
22
        'style.css'  => 'text/css',
 
23
        'index.tt'   => 'text/x-perltt',
 
24
        'main.c'     => 'text/x-c',
 
25
        'oop.cpp'    => 'text/x-c++src',
 
26
        'patch.diff' => 'text/x-patch',
 
27
        'index.html' => 'text/html',
 
28
        'index.htm'  => 'text/html',
 
29
        'script.js'  => 'application/javascript',
 
30
        'config.php' => 'application/x-php',
 
31
        'form.rb'    => 'application/x-ruby',
 
32
        'foo.bar'    => 'text/plain',
 
33
);
 
34
 
 
35
my %existing_test_files = (
 
36
        'broken.bin'                     => undef,               # regression test for ticket #900
 
37
        'lexical_replace_stress_test.pl' => 'application/x-perl',
 
38
);
 
39
 
 
40
my @files = File::Find::Rule->relative->file->name('*.pm')->in('lib');
 
41
 
 
42
plan(     tests => ( 2 * @files ) + 1 
 
43
                + scalar( keys(%test_texts) ) 
 
44
                + scalar( keys(%test_files) )
 
45
                + scalar( keys(%existing_test_files) ) );
 
46
 
 
47
use_ok('Padre::MimeTypes');
 
48
 
 
49
# Fake installed Perl6 plugin
 
50
Padre::MimeTypes->add_mime_class( 'application/x-perl6', __PACKAGE__ );
 
51
 
 
52
# All Padre modules should be Perl files and Padre should be able to detect his own files
 
53
foreach my $file (@files) {
 
54
 
 
55
        $file = "lib/$file";
 
56
 
 
57
        my $text = slurp($file);
 
58
 
 
59
        is( Padre::MimeTypes->guess_mimetype( $text, $file ), 'application/x-perl', $file . ' with filename' );
 
60
        is( Padre::MimeTypes->guess_mimetype( $text, '' ),    'application/x-perl', $file . ' without filename' );
 
61
}
 
62
 
 
63
# Some fixed test texts
 
64
foreach my $text ( sort( keys(%test_texts) ) ) {
 
65
        is( Padre::MimeTypes->guess_mimetype( $text, '' ), $test_texts{$text}, $test_texts{$text} );
 
66
}
 
67
 
 
68
# Some fixed test filenames
 
69
foreach my $file ( sort( keys(%test_files) ) ) {
 
70
        is( Padre::MimeTypes->guess_mimetype( '', $file ), $test_files{$file}, $file );
 
71
}
 
72
 
 
73
# Some files that actually exist on-disk
 
74
foreach my $file ( sort keys %existing_test_files ) {
 
75
        my $text = slurp("xt/files/$file");
 
76
 
 
77
        require Padre::Locale;
 
78
        my $encoding = Padre::Locale::encoding_from_string($text);
 
79
        $text = Encode::decode( $encoding, $text );
 
80
 
 
81
        is( Padre::MimeTypes->guess_mimetype( $text, '' ), $existing_test_files{$file}, $file . ' without filename' );
 
82
}
 
83
 
 
84
 
 
85
######################################################################
 
86
# Support Functions
 
87
 
 
88
sub slurp {
 
89
        my $file = shift;
 
90
        open my $fh, '<', $file or die $! . ' for ' . $file;
 
91
        local $/ = undef;
 
92
        my $buffer = <$fh>;
 
93
        close $fh;
 
94
        return $buffer;
 
95
}