Gecko [ fernandoquevedodop.com ]

Name	Size	Permission
appstream.pm	3.03 KB	-rw-r--r--
control_file.pm	2.76 KB	-rw-r--r--
copyright_file.pm	3.88 KB	-rw-r--r--
list_file.pm	4.42 KB	-rw-r--r--
patch_files.pm	3.99 KB	-rw-r--r--
systemd.pm	2.77 KB	-rw-r--r--
upstream_metadata.pm	4.55 KB	-rw-r--r--

Code Editor : upstream_metadata.pm

# duck - check for upstream metadata files

# Copyright (C) 2016 Simon Kainz <skainz@debian.org>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# he Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# On Debian GNU/Linux systems, the complete text of the GNU General
# Public License can be found in `/usr/share/common-licenses/GPL-2'.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, you can find it on the World Wide
# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

package DUCK::upstream_metadata;

use strict;
use warnings;
use autodie;
use Data::Dumper;
use Parse::DebControl qw(parse_file);
use YAML::XS qw(Load);
use Regexp::Common qw /URI Email::Address/;
#use Mail::Address;

my @upstream_filenames=("debian/upstream",
			"debian/upstream-metadata.yaml",
			"debian/upstream/metadata");

my $extract_hash;

my @extract=("Homepage",
	     "Repository",
	     "Repository-Browse",
	     "Screenshots",
	     "Bug-Submit",
	     "Bug-Database",
	     "Changelog",
	     "Donation",
	     "FAQ",
	     "Gallery",
	     "Other-References",
	     "Webservice",
	     "Reference",
	     "URL",
	     "Eprint");

sub proc($;$;$;$;$);
sub guess_type($);

my %options=(
    "u:" => "  -u file\tspecify path to upstream metadata file",
    "U" =>  "  -U\t\tskip processing of upstream metadata file");

sub opts()
{
    return keys %options;
}

sub desc()
{
    my $r;
    foreach (sort keys %options)
    {
	$r.=$options{$_}."\n";
    }
    return $r;
}

sub run()
{
    my $upstream_filename;
    my ($sname,$params,$entries_ref)=@_;
    my %opt=%$params;
  #  my @entries=@$entries_ref;

my @yaml_urls;

foreach my $a (@extract)
{
    $extract_hash->{$a}=1;
}

#print Dumper @extract;
#print Dumper $extract_hash;

if ($opt{u})
{
    if (! -r $opt{u})
    {
	print STDERR "Unable to open user-specified upstream metadata file: ".$opt{u}."\n";
	exit(2);
    }
    @upstream_filenames=($opt{u});
}

#Processing upstream metadata file
if (!$opt{U})
{
# extend list of urls by urls from upstream metadata
    foreach (@upstream_filenames)
    {
	@yaml_urls=();
	
	if ( -f $_)
	{
	    $upstream_filename=$_;
	    open my $fh,"<",$_;
	    
	    my @raw=<$fh>;
	    my $raw_string=join("",@raw);
	    
	    close($fh);
	my $hashref;

eval { Load($raw_string);}; if (!$@)
	    {
		$hashref=Load($raw_string);
	#	print Dumper $hashref;
		foreach my $k (keys %{$hashref})
		{
			proc("",\@yaml_urls,$k,$hashref->{$k});
		}
		
	    }
	    
	}

foreach my $yaml_url(@yaml_urls)
	{
	    # try to be smart: git:// and svn:// based urls must not be handled 
	    # by curl.
	    
	    my $keyname=_guess_type(@$yaml_url[1]); 
	    
	    if (!$keyname) {$keyname="URL";}
	    @$yaml_url[1] =~ s/^\s*//;
	#    print "ff\n";
#	    push (@$entries_ref, [$upstream_filename.": ".@$yaml_url[2],$keyname,@$yaml_url[1] ]);
	    push (@$entries_ref, [$upstream_filename.": ".@$yaml_url[2],$keyname,@$yaml_url[1],0,
				  
				  
				  {filename => $upstream_filename,
#				   linenumber => $linenum,
				   checkmethod =>$keyname,
				   url=>@$yaml_url[1],
				   certainty=>"wild-guess"} 
				  
				  
		  ]);
	    
	    
	}
    }
    
}

return;
}

sub proc($;$;$;$;$)
{

my ($sp,$ref,$key,$r,$p)=@_;
    my $t=ref($r);
#    print "$key\n";
    if ($t eq "HASH")
    {
#    print "\thash\n";
	my %a=%{$r};
#    	    print Dumper keys %a;
	foreach my $e (keys %a)
	{

#	    print "\t:$e\n";
	    proc($sp,$ref,$e,$a{$e},$key);
	}
	
    }
    
    
    if ($t eq "ARRAY")
    {
#    print "\array\n";
	my @a=@{$r};
	foreach my $e (@a)
	{
	    proc($sp,$ref,$key,$e,$key);
	}
    }
    
    if ($t eq "")
    {
#    print "\t end point\n";
#    print Dumper $extract_hash;
	if ($extract_hash->{$key})
	{
#	    print "adding key $key to data\n";
	    my @data=($sp,$r,$key);
	    push(@{$ref},\@data);
	}
    }
}

sub _guess_type($)
{

my ($url)=@_;
    return "Vcs-Git" if ($url =~/^\s*git:\/\//);
    return "Vcs-Svn" if ($url =~/^\s*svn:\/\//);
    return "URL" if ($url =~/$RE{URI}{HTTP}{-scheme =>"https?"}/);
    return "URL" if ($url =~/$RE{URI}{FTP}/);
    return undef;

}

${this.title}

Code Editor : upstream_metadata.pm