Here's a rough draft (working properly, however) of one way to do it. I'm using a couple of hashes to reduce each array to simply a count of each element. Then the lesser of the two counts becomes the number of times set three should contain a given element.

use strict;
use warnings;
use List::Util qw/min/;

my @list_a = qw/test test1 test2 test2 test/;

my @list_b = qw/test1 test2 test2/;

my( %element_count_a,
    %element_count_b
);

%element_count_a = %{ count( \@list_a ) };
%element_count_b = %{ count( \@list_b ) };


foreach my $key ( keys %element_count_a ) {
    foreach (   1 .. 
                min( $element_count_a{$key}, 
                exists( $element_count_b{$key} ) 
                    ? $element_count_b{$key} 
                    : '0' 
                ) 
    ) {
        print $key, "\n";
    }
}


sub count {
    my( $list_aref ) = shift;
    my %element_count;
    foreach my $item ( @{ $list_aref } ) {
        $element_count{$item}++;
    }
    return \%element_count;
}
[download]

Updated to choose better variable names.

I don't think the "way to do it" of your update really does it, if I understand correctly what "it" is ... that way would result in two copies of any element that was twice in @temp2, whether it was once, twice, or three or more times in @temp.

Provided I understand correctly what "it" is, I'd count up and down:

my %count; $count{$_}++ for @temp;
my @non_unique_intersection = grep { $count{$_}-->0 } @temp2;
[download]

This will preserve the order of elements of @temp2, until the count (initially the frequency in @temp of that element's string equivalence class) has been exhausted.

Update: Might as well make a function, while I'm at it:

# my @non_unique_intersection = nonunique_intersect( \@temp, \@temp2 )
+;

sub nonunique_intersect {
  my ($x, $y) = @_;
  my %count; $count{$_}++ for @$x;
  my @return = grep { $count{$_}-->0 } @$y;
  return wantarray ? @return : \@return;
}
[download]

Update 2: For your next challenge, the non-unique intersection, leftovers from @temp, and leftovers from @temp2; assuming that the bag of ( @temp, @temp2 ) is supposed to be the same as the bag of ( (@non_unique_intersection) x 2, @leftovers, @leftovers2 ):

my %count; $count{$_}++ for @temp;
my @non_unique_intersection = grep { $count{$_}-->0 } @temp2;
my (@leftovers, @leftovers2);
push @{$count{$_}>0 ? \@leftovers : \@leftovers2}, ($_) x abs($count{$
+_}) for keys %count;
[download]

how right you are! thanks for pointing that out. ++

I am not an expert on List::Compare, but my instinct would be that it doesn't handle your requirement. My spotty mathematics background associates the word "intersection" with "set theory". And sets (unlike lists) consist by definition of unique elements.

That being said, it would be possible to roll your own "non-unique" intersection using loops, like so^*:

my @results = nonunique_intersect(\@temp, \@temp2);

# ...

sub nonunique_intersect{
    my ($a1, $a2) = @_;

    my @unused_list = @$a2;
    my @results = ();

    for (@$a1){ # For each element in the first array...

        for (my $i = 0; $i < @unused_list; $i++){ # Search for it in
                                                  # the 2nd array...
            if ($unused_list[$i] eq $_){ # if found, add to results,
                                         # remove from unused list.
                push @results, splice @unused_list, $i, 1,
                               (@unused_list[$i+1 .. $#unused_list]);
                last;
            }
        }
    }

    return @results;
}
[download]

^*Tested only with your example sets!

Another way to do it since davido implemented my first idea:

use warnings;
use strict;

my @array1 = qw(
        test
        test1
        test
        test2
        test2
        test
        );
        
my @array2 = qw(
        test1
        test2
        test2
        );
my @result;

@array1 = sort @array1;
@array2 = sort @array2;

while (@array1 && @array2) {
    if ($array1[0] lt $array2[0]) {
        shift @array1;
    } elsif ($array2[0] lt $array1[0]) {
        shift @array2;
    } else {
        push @result, shift @array1;
        shift @array2;
    }
}

print join "\n", @result;
[download]

Prints:

test1
test2
test2
[download]

my (@non_unique_temp,@non_unique_temp2) ;
(!in_array($_,\@temp)) && (push @non_unique_temp2, $_)  for (@temp2);
(!in_array($_,\@temp2)) && (push @non_unique_temp, $_)  for (@temp);

sub in_array {
   ($_ eq $_[0]) && (return $_) for (@{$_[1]})  ;
}
[download]

my (@unique_temp,@unique_temp2) ;
(!in_array($_,[@temp, @unique_temp2])) && (push @unique_temp2, $_) for
+ (@temp2);
(!in_array($_,[@temp2,@unique_temp])) && (push @unique_temp, $_) for (
+@temp);
[download]

my @non_unique;
(in_array($_,\@temp)) && (push @non_unique, $_)  for (@temp2);

sub in_array {
   ($_ eq $_[0]) && (return $_) for (@{$_[1]})  ;
}
[download]

#!/usr/bin/perl
use warnings;
use strict;

my @temp1 = qw( test test1 test test2 test2 test );
print "----------------------\nContents of Temp1 Array\n";
print map "\t$_\n", @temp1;

my @temp2 = qw( test1 test2 test2 );
print "----------------------\nContents of Temp2 Array\n";
print map "\t$_\n", @temp2;

my %temp1;
$temp1{ $_ }++ for @temp1;

my %temp2;
$temp2{ $_ }++ for @temp2;


print "----------------------\nThe (Unique) Intersection of Temp1 and 
+Temp2 Arrays\n";
for my $key ( grep exists( $temp2{ $_ } ), keys %temp1 ) {
    my $count = $temp2{ $key } < $temp1{ $key } ? $temp2{ $key } : $te
+mp1{ $key };
    print map "\t$_\n", ( $key ) x $count;
    }
[download]